Theory Markov_Models_Auxiliary
section ‹Auxiliary Theory›
text ‹Parts of it should be moved to the Isabelle repository›
theory Markov_Models_Auxiliary
imports
"HOL-Probability.Probability"
"HOL-Library.Rewrite"
"HOL-Library.Linear_Temporal_Logic_on_Streams"
Coinductive.Coinductive_Stream
Coinductive.Coinductive_Nat
begin
lemma lfp_upperbound: "(⋀y. x ≤ f y) ⟹ x ≤ lfp f"
unfolding lfp_def by (intro Inf_greatest) (auto intro: order_trans)
lemma lfp_arg: "(λt. lfp (F t)) = lfp (λx t. F t (x t))"
apply (auto simp: lfp_def le_fun_def fun_eq_iff intro!: Inf_eqI Inf_greatest)
subgoal for x y
by (rule INF_lower2[of "top(x := y)"]) auto
done
lemma lfp_pair: "lfp (λf (a, b). F (λa b. f (a, b)) a b) (a, b) = lfp F a b"
unfolding lfp_def
by (auto intro!: INF_eq simp: le_fun_def)
(auto intro!: exI[of _ "λ(a, b). x a b" for x])
lemma all_Suc_split: "(∀i. P i) ⟷ (P 0 ∧ (∀i. P (Suc i)))"
using nat_induct by auto
definition "with P f d = (if ∃x. P x then f (SOME x. P x) else d)"
lemma withI[case_names default exists]:
"((⋀x. ¬ P x) ⟹ Q d) ⟹ (⋀x. P x ⟹ Q (f x)) ⟹ Q (with P f d)"
unfolding with_def by (auto intro: someI2)
context order
begin
definition
"maximal f S = {x∈S. ∀y∈S. f y ≤ f x}"
lemma maximalI: "x ∈ S ⟹ (⋀y. y ∈ S ⟹ f y ≤ f x) ⟹ x ∈ maximal f S"
by (simp add: maximal_def)
lemma maximalI_trans: "x ∈ maximal f S ⟹ f x ≤ f y ⟹ y ∈ S ⟹ y ∈ maximal f S"
unfolding maximal_def by (blast intro: antisym order_trans)
lemma maximalD1: "x ∈ maximal f S ⟹ x ∈ S"
by (simp add: maximal_def)
lemma maximalD2: "x ∈ maximal f S ⟹ y ∈ S ⟹ f y ≤ f x"
by (simp add: maximal_def)
lemma maximal_inject: "x ∈ maximal f S ⟹ y ∈ maximal f S ⟹ f x = f y"
by (rule order.antisym) (simp_all add: maximal_def)
lemma maximal_empty[simp]: "maximal f {} = {}"
by (simp add: maximal_def)
lemma maximal_singleton[simp]: "maximal f {x} = {x}"
by (auto simp add: maximal_def)
lemma maximal_in_S: "maximal f S ⊆ S"
by (auto simp: maximal_def)
end
context linorder
begin
lemma maximal_ne:
assumes "finite S" "S ≠ {}"
shows "maximal f S ≠ {}"
using assms
proof (induct rule: finite_ne_induct)
case (insert s S)
show ?case
proof cases
assume "∀x∈S. f x ≤ f s"
with insert have "s ∈ maximal f (insert s S)"
by (auto intro!: maximalI)
then show ?thesis
by auto
next
assume "¬ (∀x∈S. f x ≤ f s)"
then have "maximal f (insert s S) = maximal f S"
by (auto simp: maximal_def)
with insert show ?thesis
by auto
qed
qed simp
end
lemma mono_les:
fixes s S N and l1 l2 :: "'a ⇒ real" and K :: "'a ⇒ 'a pmf"
defines "Δ x ≡ l2 x - l1 x"
assumes s: "s ∈ S" and S: "(⋃s∈S. set_pmf (K s)) ⊆ S ∪ N"
assumes int_l1[simp]: "⋀s. s ∈ S ⟹ integrable (K s) l1"
assumes int_l2[simp]: "⋀s. s ∈ S ⟹ integrable (K s) l2"
assumes to_N: "⋀s. s ∈ S ⟹ ∃t∈N. (s, t) ∈ (SIGMA s:UNIV. K s)⇧*"
assumes l1: "⋀s. s ∈ S ⟹ (∫t. l1 t ∂K s) + c s ≤ l1 s"
assumes l2: "⋀s. s ∈ S ⟹ l2 s ≤ (∫t. l2 t ∂K s) + c s"
assumes eq: "⋀s. s ∈ N ⟹ l2 s ≤ l1 s"
assumes finitary: "finite (Δ ` (S∪N))"
shows "l2 s ≤ l1 s"
proof -
define M where "M = {s∈S∪N. ∀t∈S∪N. Δ t ≤ Δ s}"
have [simp]: "⋀s. s∈S ⟹ integrable (K s) Δ"
by (simp add: Δ_def[abs_def])
have M_unqiue: "⋀s t. s ∈ M ⟹ t ∈ M ⟹ Δ s = Δ t"
by (auto intro!: antisym simp: M_def)
have M1: "⋀s. s ∈ M ⟹ s ∈ S ∪ N"
by (auto simp: M_def)
have M2: "⋀s t. s ∈ M ⟹ t ∈ S ∪ N ⟹ Δ t ≤ Δ s"
by (auto simp: M_def)
have M3: "⋀s t. s ∈ M ⟹ t ∈ S ∪ N ⟹ t ∉ M ⟹ Δ t < Δ s"
by (auto simp: M_def less_le)
have N: "∀s∈N. Δ s ≤ 0"
using eq by (simp add: Δ_def)
{ fix s assume s: "s ∈ M" "M ∩ N = {}"
then have "s ∈ S - N"
by (auto dest: M1)
with to_N[of s] obtain t where "(s, t) ∈ (SIGMA s:UNIV. K s)⇧*" and "t ∈ N"
by (auto simp: M_def)
from this(1) ‹s ∈ M› have "Δ s ≤ 0"
proof (induction rule: converse_rtrancl_induct)
case (step s s')
then have s: "s ∈ M" "s ∈ S" "s ∉ N" and s': "s' ∈ S ∪ N" "s' ∈ K s"
using S ‹M ∩ N = {}› by (auto dest: M1)
have "s' ∈ M"
proof (rule ccontr)
assume "s' ∉ M"
with ‹s ∈ S› s' ‹s ∈ M›
have "0 < pmf (K s) s'" "Δ s' < Δ s"
by (auto intro: M2 M3 pmf_positive)
have "Δ s ≤ ((∫t. l2 t ∂K s) + c s) - ((∫t. l1 t ∂K s) + c s)"
unfolding Δ_def using ‹s ∈ S› ‹s ∉ N› by (intro diff_mono l1 l2) auto
then have "Δ s ≤ (∫s'. Δ s' ∂K s)"
using ‹s ∈ S› by (simp add: Δ_def)
also have "… < (∫s'. Δ s ∂K s)"
using ‹s' ∈ K s› ‹Δ s' < Δ s› ‹s∈S› S ‹s∈M›
by (intro measure_pmf.integral_less_AE[where A="{s'}"])
(auto simp: emeasure_measure_pmf_finite AE_measure_pmf_iff set_pmf_iff[symmetric]
intro!: M2)
finally show False
using measure_pmf.prob_space[of "K s"] by simp
qed
with step.IH ‹t∈N› N have "Δ s' ≤ 0" "s' ∈ M"
by auto
with ‹s∈S› show "Δ s ≤ 0"
by (force simp: M_def)
qed (insert N ‹t∈N›, auto) }
show ?thesis
proof cases
assume "M ∩ N = {}"
have "Max (Δ`(S∪N)) ∈ Δ`(S∪N)"
using ‹s ∈ S› by (intro Max_in finitary) auto
then obtain t where "t ∈ S ∪ N" "Δ t = Max (Δ`(S∪N))"
unfolding image_iff by metis
then have "t ∈ M"
by (auto simp: M_def finitary intro!: Max_ge)
have "Δ s ≤ Δ t"
using ‹t∈M› ‹s∈S› by (auto dest: M2)
also have "Δ t ≤ 0"
using ‹t∈M› ‹M ∩ N = {}› by fact
finally show ?thesis
by (simp add: Δ_def)
next
assume "M ∩ N ≠ {}"
then obtain t where "t ∈ M" "t ∈ N" by auto
with N ‹s∈S› have "Δ s ≤ 0"
by (intro order_trans[of "Δ s" "Δ t" 0]) (auto simp: M_def)
then show ?thesis
by (simp add: Δ_def)
qed
qed
lemma unique_les:
fixes s S N and l1 l2 :: "'a ⇒ real" and K :: "'a ⇒ 'a pmf"
defines "Δ x ≡ l2 x - l1 x"
assumes s: "s ∈ S" and S: "(⋃s∈S. set_pmf (K s)) ⊆ S ∪ N"
assumes "⋀s. s ∈ S ⟹ integrable (K s) l1"
assumes "⋀s. s ∈ S ⟹ integrable (K s) l2"
assumes "⋀s. s ∈ S ⟹ ∃t∈N. (s, t) ∈ (SIGMA s:UNIV. K s)⇧*"
assumes "⋀s. s ∈ S ⟹ l1 s = (∫t. l1 t ∂K s) + c s"
assumes "⋀s. s ∈ S ⟹ l2 s = (∫t. l2 t ∂K s) + c s"
assumes "⋀s. s ∈ N ⟹ l2 s = l1 s"
assumes 1: "finite (Δ ` (S∪N))"
shows "l2 s = l1 s"
proof -
have "finite ((λx. l2 x - l1 x) ` (S∪N))"
using 1 by (auto simp: Δ_def[abs_def])
moreover then have "finite (uminus ` (λx. l2 x - l1 x) ` (S∪N))"
by auto
ultimately show ?thesis
using assms
by (intro antisym mono_les[of s S K N l2 l1 c] mono_les[of s S K N l1 l2 c])
(auto simp: image_comp comp_def)
qed
lemma inf_continuous_suntil_disj[order_continuous_intros]:
assumes Q: "inf_continuous Q"
assumes disj: "⋀x ω. ¬ (P ω ∧ Q x ω)"
shows "inf_continuous (λx. P suntil Q x)"
unfolding inf_continuous_def
proof (safe intro!: ext)
fix M ω i assume "(P suntil Q (⨅i. M i)) ω" "decseq M" then show "(P suntil Q (M i)) ω"
unfolding inf_continuousD[OF Q ‹decseq M›] by induction (auto intro: suntil.intros)
next
fix M ω assume *: "(⨅i. P suntil Q (M i)) ω" "decseq M"
then have "(P suntil Q (M 0)) ω"
by auto
from this * show "(P suntil Q (⨅i. M i)) ω"
unfolding inf_continuousD[OF Q ‹decseq M›]
proof induction
case (base ω) with disj[of ω "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
next
case (step ω) with disj[of ω "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
qed
qed
lemma inf_continuous_nxt[order_continuous_intros]: "inf_continuous P ⟹ inf_continuous (λx. nxt (P x) ω)"
by (auto simp: inf_continuous_def image_comp)
lemma sup_continuous_nxt[order_continuous_intros]: "sup_continuous P ⟹ sup_continuous (λx. nxt (P x) ω)"
by (auto simp: sup_continuous_def image_comp)
lemma mcont_ennreal_of_enat: "mcont Sup (≤) Sup (≤) ennreal_of_enat"
by (auto intro!: mcontI monotoneI contI ennreal_of_enat_Sup)
lemma mcont2mcont_ennreal_of_enat[cont_intro]:
"mcont lub ord Sup (≤) f ⟹ mcont lub ord Sup (≤) (λx. ennreal_of_enat (f x))"
by (auto intro: ccpo.mcont2mcont[OF complete_lattice_ccpo'] mcont_ennreal_of_enat)
declare stream.exhaust[cases type: stream]
lemma scount_eq_emeasure: "scount P ω = emeasure (count_space UNIV) {i. P (sdrop i ω)}"
proof cases
assume "alw (ev P) ω"
moreover then have "infinite {i. P (sdrop i ω)}"
using infinite_iff_alw_ev[of P ω] by simp
ultimately show ?thesis
by (simp add: scount_infinite_iff[symmetric])
next
assume "¬ alw (ev P) ω"
moreover then have "finite {i. P (sdrop i ω)}"
using infinite_iff_alw_ev[of P ω] by simp
ultimately show ?thesis
by (simp add: not_alw_iff not_ev_iff scount_eq_card)
qed
lemma measurable_scount[measurable]:
assumes [measurable]: "Measurable.pred (stream_space M) P"
shows "scount P ∈ measurable (stream_space M) (count_space UNIV)"
unfolding scount_eq[abs_def] by measurable
lemma measurable_sfirst2:
assumes [measurable]: "Measurable.pred (N ⨂⇩M stream_space M) (λ(x, ω). P x ω)"
shows "(λ(x, ω). sfirst (P x) ω) ∈ measurable (N ⨂⇩M stream_space M) (count_space UNIV)"
apply (coinduction rule: measurable_enat_coinduct)
apply simp
apply (rule exI[of _ "λx. 0"])
apply (rule exI[of _ "λ(x, ω). (x, stl ω)"])
apply (rule exI[of _ "λ(x, ω). P x ω"])
apply (subst sfirst.simps[abs_def])
apply (simp add: fun_eq_iff)
done
lemma measurable_sfirst2'[measurable (raw)]:
assumes [measurable (raw)]: "f ∈ N →⇩M stream_space M" "Measurable.pred (N ⨂⇩M stream_space M) (λx. P (fst x) (snd x))"
shows "(λx. sfirst (P x) (f x)) ∈ measurable N (count_space UNIV)"
using measurable_sfirst2[measurable] by measurable
lemma measurable_sfirst[measurable]:
assumes [measurable]: "Measurable.pred (stream_space M) P"
shows "sfirst P ∈ measurable (stream_space M) (count_space UNIV)"
by measurable
lemma measurable_epred[measurable]: "epred ∈ count_space UNIV →⇩M count_space UNIV"
by (rule measurable_count_space)
lemma nn_integral_stretch:
"f ∈ borel →⇩M borel ⟹ c ≠ 0 ⟹ (∫⇧+x. f (c * x) ∂lborel) = (1 / ¦c¦::real) * (∫⇧+x. f x ∂lborel)"
using nn_integral_real_affine[of f c 0] by (simp add: mult.assoc[symmetric] ennreal_mult[symmetric])
lemma prod_sum_distrib:
fixes f g :: "'a ⇒ 'b ⇒ 'c::comm_semiring_1"
assumes "finite I" shows "(⋀i. i ∈ I ⟹ finite (J i)) ⟹ (∏i∈I. ∑j∈J i. f i j) = (∑m∈Pi⇩E I J. ∏i∈I. f i (m i))"
using ‹finite I›
proof induction
case (insert i I) then show ?case
by (auto simp: PiE_insert_eq finite_PiE sum.reindex inj_combinator sum.swap[of _ "Pi⇩E I J"]
sum_cartesian_product' sum_distrib_left sum_distrib_right
intro!: sum.cong prod.cong arg_cong[where f="(*) x" for x])
qed simp
lemma prod_add_distrib:
fixes f g :: "'a ⇒ 'b::comm_semiring_1"
assumes "finite I" shows "(∏i∈I. f i + g i) = (∑J∈Pow I. (∏i∈J. f i) * (∏i∈I - J. g i))"
proof -
have "(∏i∈I. f i + g i) = (∏i∈I. ∑b∈{True, False}. if b then f i else g i)"
by simp
also have "… = (∑m∈I →⇩E {True, False}. ∏i∈I. if m i then f i else g i)"
using ‹finite I› by (rule prod_sum_distrib) simp
also have "… = (∑J∈Pow I. (∏i∈J. f i) * (∏i∈I - J. g i))"
by (rule sum.reindex_bij_witness[where i="λJ. λi∈I. i∈J" and j="λm. {i∈I. m i}"])
(auto simp: fun_eq_iff prod.If_cases ‹finite I› intro!: arg_cong2[where f="(*)"] prod.cong)
finally show ?thesis .
qed
subclass (in linordered_nonzero_semiring) ordered_semiring_0
proof qed
lemma (in linordered_nonzero_semiring) prod_nonneg: "(∀a∈A. 0 ≤ f a) ⟹ 0 ≤ prod f A"
by (induct A rule: infinite_finite_induct) simp_all
lemma (in linordered_nonzero_semiring) prod_mono:
"∀i∈A. 0 ≤ f i ∧ f i ≤ g i ⟹ prod f A ≤ prod g A"
by (induct A rule: infinite_finite_induct) (auto intro!: prod_nonneg mult_mono)
lemma (in linordered_nonzero_semiring) prod_mono2:
assumes "finite J" "I ⊆ J" "⋀i. i ∈ I ⟹ 0 ≤ g i ∧ g i ≤ f i" "(⋀i. i ∈ J - I ⟹ 1 ≤ f i)"
shows "prod g I ≤ prod f J"
proof -
have "prod g I = (∏i∈J. if i ∈ I then g i else 1)"
using ‹finite J› ‹I ⊆ J› by (simp add: prod.If_cases Int_absorb1)
also have "… ≤ prod f J"
using assms by (intro prod_mono) auto
finally show ?thesis .
qed
lemma (in linordered_nonzero_semiring) prod_mono3:
assumes "finite J" "I ⊆ J" "⋀i. i ∈ J ⟹ 0 ≤ g i" "⋀i. i ∈ I ⟹ g i ≤ f i" "(⋀i. i ∈ J - I ⟹ g i ≤ 1)"
shows "prod g J ≤ prod f I"
proof -
have "prod g J ≤ (∏i∈J. if i ∈ I then f i else 1)"
using assms by (intro prod_mono) auto
also have "… = prod f I"
using ‹finite J› ‹I ⊆ J› by (simp add: prod.If_cases Int_absorb1)
finally show ?thesis .
qed
lemma (in linordered_nonzero_semiring) one_le_prod: "(⋀i. i ∈ I ⟹ 1 ≤ f i) ⟹ 1 ≤ prod f I"
proof (induction I rule: infinite_finite_induct)
case (insert i I) then show ?case
using mult_mono[of 1 "f i" 1 "prod f I"]
by (auto intro: order_trans[OF zero_le_one])
qed auto
lemma sum_plus_one_le_prod_plus_one:
fixes p :: "'a ⇒ 'b::linordered_nonzero_semiring"
assumes "⋀i. i ∈ I ⟹ 0 ≤ p i"
shows "(∑i∈I. p i) + 1 ≤ (∏i∈I. p i + 1)"
proof cases
assume [simp]: "finite I"
with assms have [simp]: "J ⊆ I ⟹ 0 ≤ prod p J" for J
by (intro prod_nonneg) auto
have "1 + (∑i∈I. p i) = (∑J∈insert {} ((λx. {x})`I). (∏i∈J. p i) * (∏i∈I - J. 1))"
by (subst sum.insert) (auto simp: sum.reindex)
also have "… ≤ (∑J∈Pow I. (∏i∈J. p i) * (∏i∈I - J. 1))"
using assms by (intro sum_mono2) auto
finally show ?thesis
by (subst prod_add_distrib) (auto simp: add.commute)
qed simp
lemma summable_iff_convergent_prod:
fixes p :: "nat ⇒ real" assumes p: "⋀i. 0 ≤ p i"
shows "summable p ⟷ convergent (λn. ∏i<n. p i + 1)"
unfolding summable_iff_convergent
proof
assume "convergent (λn. ∏i<n. p i + 1)"
then obtain x where x: "(λn. ∏i<n. p i + 1) ⇢ x"
by (auto simp: convergent_def)
then have "1 ≤ x"
by (rule tendsto_lowerbound) (auto intro!: always_eventually one_le_prod p)
have "convergent (λn. 1 + (∑i<n. p i))"
proof (intro Bseq_mono_convergent BseqI allI)
show "0 < x" using ‹1 ≤ x› by auto
next
fix n
have "norm ((∑i<n. p i) + 1) ≤ (∏i<n. p i + 1)"
using p by (simp add: sum_nonneg sum_plus_one_le_prod_plus_one p)
also have "… ≤ x"
using assms
by (intro tendsto_lowerbound[OF x])
(auto simp: eventually_sequentially intro!: exI[of _ n] prod_mono2)
finally show "norm (1 + sum p {..<n}) ≤ x"
by (simp add: add.commute)
qed (insert p, auto intro!: sum_mono2)
then show "convergent (λn. ∑i<n. p i)"
unfolding convergent_add_const_iff .
next
assume "convergent (λn. ∑i<n. p i)"
then obtain x where x: "(λn. exp (∑i<n. p i)) ⇢ exp x"
by (force simp: convergent_def intro!: tendsto_exp)
show "convergent (λn. ∏i<n. p i + 1)"
proof (intro Bseq_mono_convergent BseqI allI)
show "0 < exp x" by simp
next
fix n
have "norm (∏i<n. p i + 1) ≤ exp (∑i<n. p i)"
using p exp_ge_add_one_self[of "p _"] by (auto simp add: prod_nonneg exp_sum add.commute intro!: prod_mono)
also have "… ≤ exp x"
using p
by (intro tendsto_lowerbound[OF x]) (auto simp: eventually_sequentially intro!: sum_mono2 )
finally show "norm (∏i<n. p i + 1) ≤ exp x" .
qed (insert p, auto intro!: prod_mono2)
qed
primrec eexp :: "ereal ⇒ ennreal"
where
"eexp MInfty = 0"
| "eexp (ereal r) = ennreal (exp r)"
| "eexp PInfty = top"
lemma
shows eexp_minus_infty[simp]: "eexp (-∞) = 0"
and eexp_infty[simp]: "eexp ∞ = top"
using eexp.simps by simp_all
lemma eexp_0[simp]: "eexp 0 = 1"
by (simp add: zero_ereal_def)
lemma eexp_inj[simp]: "eexp x = eexp y ⟷ x = y"
by (cases x; cases y; simp)
lemma eexp_mono[simp]: "eexp x ≤ eexp y ⟷ x ≤ y"
by (cases x; cases y; simp add: top_unique)
lemma eexp_strict_mono[simp]: "eexp x < eexp y ⟷ x < y"
by (simp add: less_le)
lemma exp_eq_0_iff[simp]: "eexp x = 0 ⟷ x = -∞"
using eexp_inj[of x "-∞"] unfolding eexp_minus_infty .
lemma eexp_surj: "range eexp = UNIV"
proof -
have part: "UNIV = {0} ∪ {0 <..< top} ∪ {top::ennreal}"
by (auto simp: less_top)
show ?thesis
unfolding part
by (force simp: image_iff less_top less_top_ennreal intro!: eexp.simps[symmetric] eexp.simps dest: exp_total)
qed
lemma continuous_on_eexp': "continuous_on UNIV eexp"
by (rule continuous_onI_mono) (auto simp: eexp_surj)
lemma continuous_on_eexp[continuous_intros]: "continuous_on A f ⟹ continuous_on A (λx. eexp (f x))"
by (rule continuous_on_compose2[OF continuous_on_eexp']) auto
lemma tendsto_eexp[tendsto_intros]: "(f ⤏ x) F ⟹ ((λx. eexp (f x)) ⤏ eexp x) F"
by (rule continuous_on_tendsto_compose[OF continuous_on_eexp']) auto
lemma measurable_eexp[measurable]: "eexp ∈ borel →⇩M borel"
using continuous_on_eexp' by (rule borel_measurable_continuous_onI)
lemma eexp_add: "¬ ((x = ∞ ∧ y = -∞) ∨ (x = -∞ ∧ y = ∞)) ⟹ eexp (x + y) = eexp x * eexp y"
by (cases x; cases y; simp add: exp_add ennreal_mult ennreal_top_mult ennreal_mult_top)
lemma sum_Pinfty:
fixes f :: "'a ⇒ ereal"
shows "sum f I = ∞ ⟷ (finite I ∧ (∃i∈I. f i = ∞))"
by (induction I rule: infinite_finite_induct) auto
lemma sum_Minfty:
fixes f :: "'a ⇒ ereal"
shows "sum f I = -∞ ⟷ (finite I ∧ ¬ (∃i∈I. f i = ∞) ∧ (∃i∈I. f i = -∞))"
by (induction I rule: infinite_finite_induct)
(auto simp: sum_Pinfty)
lemma eexp_sum: "¬ (∃i∈I. ∃j∈I. f i = -∞ ∧ f j = ∞) ⟹ eexp (∑i∈I. f i) = (∏i∈I. eexp (f i))"
proof (induction I rule: infinite_finite_induct)
case (insert i I)
have "eexp (sum f (insert i I)) = eexp (f i) * eexp (sum f I)"
using insert.prems insert.hyps by (auto simp: sum_Pinfty sum_Minfty intro!: eexp_add)
then show ?case
using insert by auto
qed simp_all
lemma eexp_suminf:
assumes wf_f: "¬ {-∞, ∞} ⊆ range f" and f: "summable f"
shows "(λn. ∏i<n. eexp (f i)) ⇢ eexp (∑i. f i)"
proof -
have "(λn. eexp (∑i<n. f i)) ⇢ eexp (∑i. f i)"
by (intro tendsto_eexp summable_LIMSEQ f)
also have "(λn. eexp (∑i<n. f i)) = (λn. ∏i<n. eexp (f i))"
using wf_f by (auto simp: fun_eq_iff image_iff eq_commute intro!: eexp_sum)
finally show ?thesis .
qed
lemma continuous_onI_antimono:
fixes f :: "'a::linorder_topology ⇒ 'b::{dense_order,linorder_topology}"
assumes "open (f`A)"
and mono: "⋀x y. x ∈ A ⟹ y ∈ A ⟹ x ≤ y ⟹ f y ≤ f x"
shows "continuous_on A f"
proof (rule continuous_on_generate_topology[OF open_generated_order], safe)
have monoD: "⋀x y. x ∈ A ⟹ y ∈ A ⟹ f y < f x ⟹ x < y"
by (auto simp: not_le[symmetric] mono)
have "∃x. x ∈ A ∧ f x < b ∧ x < a" if a: "a ∈ A" and fa: "f a < b" for a b
proof -
obtain y where "f a < y" "{f a ..< y} ⊆ f`A"
using open_right[OF ‹open (f`A)›, of "f a" b] a fa
by auto
obtain z where z: "f a < z" "z < min b y"
using dense[of "f a" "min b y"] ‹f a < y› ‹f a < b› by auto
then obtain c where "z = f c" "c ∈ A"
using ‹{f a ..< y} ⊆ f`A›[THEN subsetD, of z] by (auto simp: less_imp_le)
with a z show ?thesis
by (auto intro!: exI[of _ c] simp: monoD)
qed
then show "∃C. open C ∧ C ∩ A = f -` {..<b} ∩ A" for b
by (intro exI[of _ "(⋃x∈{x∈A. f x < b}. {x <..})"])
(auto intro: le_less_trans[OF mono] less_imp_le)
have "∃x. x ∈ A ∧ b < f x ∧ x > a" if a: "a ∈ A" and fa: "b < f a" for a b
proof -
note a fa
moreover
obtain y where "y < f a" "{y <.. f a} ⊆ f`A"
using open_left[OF ‹open (f`A)›, of "f a" b] a fa
by auto
then obtain z where z: "max b y < z" "z < f a"
using dense[of "max b y" "f a"] ‹y < f a› ‹b < f a› by auto
then obtain c where "z = f c" "c ∈ A"
using ‹{y <.. f a} ⊆ f`A›[THEN subsetD, of z] by (auto simp: less_imp_le)
with a z show ?thesis
by (auto intro!: exI[of _ c] simp: monoD)
qed
then show "∃C. open C ∧ C ∩ A = f -` {b <..} ∩ A" for b
by (intro exI[of _ "(⋃x∈{x∈A. b < f x}. {..< x})"])
(auto intro: less_le_trans[OF _ mono] less_imp_le)
qed
lemma minus_add_eq_ereal: "¬ ((a = ∞ ∧ b = -∞) ∨ (a = -∞ ∧ b = ∞)) ⟹ - (a + b::ereal) = -a - b"
by (cases a; cases b; simp)
lemma setsum_negf_ereal: "¬ {-∞, ∞} ⊆ f`I ⟹ (∑i∈I. - f i) = - (∑i∈I. f i::ereal)"
by (induction I rule: infinite_finite_induct)
(auto simp: minus_add_eq_ereal sum_Minfty sum_Pinfty,
(subst minus_add_eq_ereal; auto simp: sum_Pinfty sum_Minfty image_iff minus_ereal_def)+)
lemma convergent_minus_iff_ereal: "convergent (λx. - f x::ereal) ⟷ convergent f"
unfolding convergent_def by (metis ereal_uminus_uminus ereal_Lim_uminus)
lemma summable_minus_ereal: "¬ {-∞, ∞} ⊆ range f ⟹ summable (λn. f n) ⟹ summable (λn. - f n::ereal)"
unfolding summable_iff_convergent
by (subst setsum_negf_ereal) (auto simp: convergent_minus_iff_ereal)
lemma (in product_prob_space) product_nn_integral_component:
assumes "f ∈ borel_measurable (M i)""i ∈ I"
shows "integral⇧N (Pi⇩M I M) (λx. f (x i)) = integral⇧N (M i) f"
proof -
from assms show ?thesis
apply (subst PiM_component[symmetric, OF ‹i ∈ I›])
apply (subst nn_integral_distr[OF measurable_component_singleton])
apply simp_all
done
qed
lemma ennreal_inverse_le[simp]: "inverse x ≤ inverse y ⟷ y ≤ (x::ennreal)"
by (cases "0 < x"; cases x; cases "0 < y"; cases y; auto simp: top_unique inverse_ennreal)
lemma inverse_inverse_ennreal[simp]: "inverse (inverse x::ennreal) = x"
by (cases "0 < x"; cases x; auto simp: inverse_ennreal)
lemma range_inverse_ennreal: "range inverse = (UNIV::ennreal set)"
proof -
have "∃x. y = inverse x" for y :: ennreal
by (intro exI[of _ "inverse y"]) simp
then show ?thesis
unfolding surj_def by auto
qed
lemma continuous_on_inverse_ennreal': "continuous_on (UNIV :: ennreal set) inverse"
by (rule continuous_onI_antimono) (auto simp: range_inverse_ennreal)
lemma sums_minus_ereal: "¬ {- ∞, ∞} ⊆ f ` UNIV ⟹ (λn. - f n::ereal) sums x ⟹ f sums - x"
unfolding sums_def
apply (subst ereal_Lim_uminus)
apply (subst (asm) setsum_negf_ereal)
apply auto
done
lemma suminf_minus_ereal: "¬ {- ∞, ∞} ⊆ f ` UNIV ⟹ summable f ⟹ (∑n. - f n :: ereal) = - suminf f"
apply (rule sums_unique[symmetric])
apply (rule sums_minus_ereal)
apply (auto simp: ereal_uminus_eq_reorder)
done
end
Theory Discrete_Time_Markov_Chain
section ‹Discrete-Time Markov Chain›
theory Discrete_Time_Markov_Chain
imports Markov_Models_Auxiliary
begin
text ‹
Markov chain with discrete time steps and discrete state space.
›
lemma sstart_eq': "sstart Ω (x # xs) = {ω. shd ω = x ∧ stl ω ∈ sstart Ω xs}"
by (auto simp: sstart_eq)
lemma measure_eq_stream_space_coinduct[consumes 1, case_names left right cont]:
assumes "R N M"
assumes R_1: "⋀N M. R N M ⟹ N ∈ space (prob_algebra (stream_space (count_space UNIV)))"
and R_2: "⋀N M. R N M ⟹ M ∈ space (prob_algebra (stream_space (count_space UNIV)))"
and cont: "⋀N M. R N M ⟹ ∃N' M' p. (∀y∈set_pmf p. R (N' y) (M' y)) ∧
(∀x. N' x ∈ space (prob_algebra (stream_space (count_space UNIV)))) ∧ (∀x. M' x ∈ space (prob_algebra (stream_space (count_space UNIV)))) ∧
N = (measure_pmf p ⤜ (λy. distr (N' y) (stream_space (count_space UNIV)) ((##) y))) ∧
M = (measure_pmf p ⤜ (λy. distr (M' y) (stream_space (count_space UNIV)) ((##) y)))"
shows "N = M"
proof -
let ?S = "stream_space (count_space UNIV)"
have "∀N M. R N M ⟶ (∃N' M' p. (∀y∈set_pmf p. R (N' y) (M' y)) ∧
(∀x. N' x ∈ space (prob_algebra ?S)) ∧ (∀x. M' x ∈ space (prob_algebra ?S)) ∧
N = (measure_pmf p ⤜ (λy. distr (N' y) ?S ((##) y))) ∧
M = (measure_pmf p ⤜ (λy. distr (M' y) ?S ((##) y))))"
using cont by auto
then obtain n m p where
p: "⋀N M y. R N M ⟹ y ∈ set_pmf (p N M) ⟹ R (n N M y) (m N M y)" and
n: "⋀N M x. R N M ⟹ n N M x ∈ space (prob_algebra ?S)" and
n_eq: "⋀N M y. R N M ⟹ N = (measure_pmf (p N M) ⤜ (λy. distr (n N M y) ?S ((##) y)))" and
m: "⋀N M x. R N M ⟹ m N M x ∈ space (prob_algebra ?S)" and
m_eq: "⋀N M y. R N M ⟹ M = (measure_pmf (p N M) ⤜ (λy. distr (m N M y) ?S ((##) y)))"
unfolding choice_iff' choice_iff by blast
define A where "A = (SIGMA nm:UNIV. (λx. (n (fst nm) (snd nm) x, m (fst nm) (snd nm) x)) ` p (fst nm) (snd nm))"
have A_singleton: "A `` {nm} = (λx. (n (fst nm) (snd nm) x, m (fst nm) (snd nm) x)) ` p (fst nm) (snd nm)" for nm
by (auto simp: A_def)
have sets_n[measurable_cong, simp]: "sets (n N M y) = sets ?S" if "R N M" for N M y
using n[OF that, of y] by (auto simp: space_prob_algebra)
have sets_m[measurable_cong, simp]: "sets (m N M y) = sets ?S" if "R N M" for N M y
using m[OF that, of y] by (auto simp: space_prob_algebra)
have [simp]: "R N M ⟹ prob_space (n N M y)" for N M y
using n[of N M y] by (auto simp: space_prob_algebra)
have [simp]: "R N M ⟹ prob_space (m N M y)" for N M y
using m[of N M y] by (auto simp: space_prob_algebra)
have [measurable]: "R N M ⟹ n N M ∈ count_space UNIV →⇩M subprob_algebra ?S" for N M
by (rule measurable_prob_algebraD) (auto intro: n)
have [measurable]: "R N M ⟹ m N M ∈ count_space UNIV →⇩M subprob_algebra ?S" for N M
by (rule measurable_prob_algebraD) (auto intro: m)
define n' where "n' N M y = distr (n N M y) ?S ((##) y)" for N M y
define m' where "m' N M y = distr (m N M y) ?S ((##) y)" for N M y
have n'_eq: "R N M ⟹ N = (measure_pmf (p N M) ⤜ n' N M)" for N M unfolding n'_def by (rule n_eq)
have m'_eq: "R N M ⟹ M = (measure_pmf (p N M) ⤜ m' N M)" for N M unfolding m'_def by (rule m_eq)
have [measurable]: "R N M ⟹ n' N M ∈ count_space UNIV →⇩M subprob_algebra ?S" for N M
unfolding n'_def by (rule measurable_distr2[where M="?S"]) measurable
have [measurable]: "R N M ⟹ m' N M ∈ count_space UNIV →⇩M subprob_algebra ?S" for N M
unfolding m'_def by (rule measurable_distr2[where M="?S"]) measurable
have n'_shd: "R N M ⟹ distr (n' N M y) (count_space UNIV) shd = measure_pmf (return_pmf y)" for N M y
unfolding n'_def by (subst distr_distr) (auto simp: comp_def prob_space.distr_const return_pmf.rep_eq)
have m'_shd: "R N M ⟹ distr (m' N M y) (count_space UNIV) shd = measure_pmf (return_pmf y)" for N M y
unfolding m'_def by (subst distr_distr) (auto simp: comp_def prob_space.distr_const return_pmf.rep_eq)
have n'_stl: "R N M ⟹ distr (n' N M y) ?S stl = n N M y" for N M y
unfolding n'_def by (subst distr_distr) (auto simp: comp_def distr_id2)
have m'_stl: "R N M ⟹ distr (m' N M y) ?S stl = m N M y" for N M y
unfolding m'_def by (subst distr_distr) (auto simp: comp_def distr_id2)
define F where "F = (A⇧* `` {(N, M)})"
have "countable F"
unfolding F_def
apply (intro countable_rtrancl countable_insert[of _ "(N, M)"] countable_empty)
apply (rule countable_Image)
apply (auto simp: A_singleton)
done
have F_NM[simp]: "(N, M) ∈ F" unfolding F_def by auto
have R_F[simp]: "R N' M'" if "(N', M') ∈ F" for N' M'
proof -
have "((N, M), (N', M')) ∈ A⇧*" using that by (auto simp: F_def)
then show "R N' M'"
by (induction p=="(N', M')" arbitrary: N' M' rule: rtrancl_induct) (auto simp: ‹R N M› A_def p)
qed
have nm_F: "(n N' M' y, m N' M' y) ∈ F" if "y ∈ p N' M'" "(N', M') ∈ F" for N' M' y
proof -
have *: "((N, M), (N', M')) ∈ A⇧*" using that by (auto simp: F_def)
with that show ?thesis
apply (simp add: F_def)
apply (intro rtrancl.rtrancl_into_rtrancl[OF *])
apply (auto simp: A_def)
done
qed
define Ω where "Ω = (⋃(n, m)∈F. set_pmf (p n m))"
have [measurable]: "Ω ∈ sets (count_space UNIV)" by auto
have in_Ω: "(N, M) ∈ F ⟹ y ∈ p N M ⟹ y ∈ Ω" for N M y
by (auto simp: Ω_def Bex_def)
show ?thesis
proof (intro stream_space_eq_sstart)
from ‹countable F› show "countable Ω"
by (auto simp add: Ω_def)
show "prob_space N" "prob_space M" "sets N = sets ?S" "sets M = sets ?S"
using R_1[OF ‹R N M›] R_2[OF ‹R N M›] by (auto simp add: space_prob_algebra)
have "⋀N M. (N, M) ∈ F ⟹ AE x in N. x !! i ∈ Ω" for i
proof (induction i)
case 0 note NM = 0[THEN R_F, simp] show ?case
apply (subst n'_eq[OF NM])
apply (subst AE_bind[where B="?S"])
apply measurable
apply (auto intro!: AE_distrD[where f=shd and M'="count_space UNIV"]
simp: AE_measure_pmf_iff n[OF NM] n'_shd in_Ω[OF 0] cong: AE_cong_simp)
done
next
case (Suc i) note NM = Suc(2)[THEN R_F, simp]
show ?case
apply (subst n'_eq[OF NM])
apply (subst AE_bind[where B="?S"])
apply measurable
apply (auto intro!: AE_distrD[where f=stl and M'="?S"] Suc(1)[OF nm_F] Suc(2)
simp: AE_measure_pmf_iff n'_stl cong: AE_cong_simp)
done
qed
then have AE_N: "⋀N M. (N, M) ∈ F ⟹ AE x in N. x ∈ streams Ω"
unfolding streams_iff_snth AE_all_countable by auto
then show "AE x in N. x ∈ streams Ω" by (blast intro: F_NM)
have "⋀N M. (N, M) ∈ F ⟹ AE x in M. x !! i ∈ Ω" for i
proof (induction i arbitrary: N M)
case 0 note NM = 0[THEN R_F, simp] show ?case
apply (subst m'_eq[OF NM])
apply (subst AE_bind[where B="?S"])
apply measurable
apply (auto intro!: AE_distrD[where f=shd and M'="count_space UNIV"]
simp: AE_measure_pmf_iff m[OF NM] m'_shd in_Ω[OF 0] cong: AE_cong_simp)
done
next
case (Suc i) note NM = Suc(2)[THEN R_F, simp]
show ?case
apply (subst m'_eq[OF NM])
apply (subst AE_bind[where B="?S"])
apply measurable
apply (auto intro!: AE_distrD[where f=stl and M'="?S"] Suc(1)[OF nm_F] Suc(2)
simp: AE_measure_pmf_iff m'_stl cong: AE_cong_simp)
done
qed
then have AE_M: "⋀N M. (N, M) ∈ F ⟹ AE x in M. x ∈ streams Ω"
unfolding streams_iff_snth AE_all_countable by auto
then show "AE x in M. x ∈ streams Ω" by (blast intro: F_NM)
fix xs assume "xs ∈ lists Ω"
with ‹(N, M) ∈ F› show "emeasure N (sstart Ω xs) = emeasure M (sstart Ω xs)"
proof (induction xs arbitrary: N M)
case Nil
have "prob_space N" "prob_space M" "sets N = sets ?S" "sets M = sets ?S"
using R_1[OF R_F[OF Nil(1)]] R_2[OF R_F[OF Nil(1)]] by (auto simp add: space_prob_algebra)
have "emeasure N (streams Ω) = 1"
by (rule prob_space.emeasure_eq_1_AE[OF ‹prob_space N› _ AE_N[OF Nil(1)]])
(auto simp add: ‹sets N = sets ?S› intro!: streams_sets)
moreover have "emeasure M (streams Ω) = 1"
by (rule prob_space.emeasure_eq_1_AE[OF ‹prob_space M› _ AE_M[OF Nil(1)]])
(auto simp add: ‹sets M = sets ?S› intro!: streams_sets)
ultimately show ?case by simp
next
case (Cons x xs)
note NM = Cons(2)[THEN R_F, simp]
have *: "(##) y -` sstart Ω (x # xs) = (if x = y then sstart Ω xs else {})" for y
by auto
show ?case
apply (subst n'_eq[OF NM])
apply (subst (3) m'_eq[OF NM])
apply (subst emeasure_bind[OF _ _ sstart_sets])
apply simp []
apply measurable []
apply (subst emeasure_bind[OF _ _ sstart_sets])
apply simp []
apply measurable []
apply (intro nn_integral_cong_AE AE_pmfI)
apply (subst n'_def)
apply (subst m'_def)
using Cons(3)
apply (auto intro!: Cons nm_F
simp add: emeasure_distr sets_eq_imp_space_eq[OF sets_n] sets_eq_imp_space_eq[OF sets_m]
space_stream_space *)
done
qed
qed
qed
subsection ‹Discrete Markov Kernel›
locale MC_syntax =
fixes K :: "'s ⇒ 's pmf"
begin
abbreviation acc :: "('s × 's) set" where
"acc ≡ (SIGMA s:UNIV. K s)⇧*"
abbreviation acc_on :: "'s set ⇒ ('s × 's) set" where
"acc_on S ≡ (SIGMA s:UNIV. K s ∩ S)⇧*"
lemma countable_reachable: "countable (acc `` {s})"
by (auto intro!: countable_rtrancl countable_set_pmf simp: Sigma_Image)
lemma countable_acc: "countable X ⟹ countable (acc `` X)"
apply (rule countable_Image)
apply (rule countable_reachable)
apply assumption
done
context
notes [[inductive_internals]]
begin
coinductive enabled where
"enabled (shd ω) (stl ω) ⟹ shd ω ∈ K s ⟹ enabled s ω"
end
lemma alw_enabled: "enabled (shd ω) (stl ω) ⟹ alw (λω. enabled (shd ω) (stl ω)) ω"
by (coinduction arbitrary: ω rule: alw_coinduct) (auto elim: enabled.cases)
abbreviation "S ≡ stream_space (count_space UNIV)"
lemma in_S [measurable (raw)]: "x ∈ space S"
by (simp add: space_stream_space)
inductive_simps enabled_iff: "enabled s ω"
lemma enabled_Stream: "enabled x (y ## ω) ⟷ y ∈ K x ∧ enabled y ω"
by (subst enabled_iff) auto
lemma measurable_enabled[measurable]:
"Measurable.pred (stream_space (count_space UNIV)) (enabled s)" (is "Measurable.pred ?S _")
unfolding enabled_def
proof (coinduction arbitrary: s rule: measurable_gfp2_coinduct)
case (step A s)
then have [measurable]: "⋀t. Measurable.pred ?S (A t)" by auto
have *: "⋀x. (∃ω t. s = t ∧ x = ω ∧ A (shd ω) (stl ω) ∧ shd ω ∈ set_pmf (K t)) ⟷
(∃t∈K s. A t (stl x) ∧ t = shd x)"
by auto
note countable_set_pmf[simp]
show ?case
unfolding * by measurable
qed (auto simp: inf_continuous_def)
lemma enabled_iff_snth: "enabled s ω ⟷ (∀i. ω !! i ∈ K ((s ## ω) !! i))"
proof safe
fix i assume "enabled s ω" then show "ω !! i ∈ K ((s ## ω) !! i)"
by (induct i arbitrary: s ω)
(force elim: enabled.cases)+
next
assume "∀i. ω !! i ∈ set_pmf (K ((s ## ω) !! i))" then show "enabled s ω"
by (coinduction arbitrary: s ω)
(auto elim: allE[of _ "Suc i" for i] allE[of _ 0])
qed
primcorec force_enabled where
"force_enabled x ω =
(let y = if shd ω ∈ K x then shd ω else (SOME y. y ∈ K x) in y ## force_enabled y (stl ω))"
lemma force_enabled_in_set_pmf[simp, intro]: "shd (force_enabled x ω) ∈ K x"
by (auto simp: some_in_eq set_pmf_not_empty)
lemma enabled_force_enabled: "enabled x (force_enabled x ω)"
by (coinduction arbitrary: x ω) (auto simp: some_in_eq set_pmf_not_empty)
lemma force_enabled: "enabled x ω ⟹ force_enabled x ω = ω"
by (coinduction arbitrary: x ω) (auto elim: enabled.cases)
lemma Ex_enabled: "∃ω. enabled x ω"
by (rule exI[of _ "force_enabled x undefined"] enabled_force_enabled)+
lemma measurable_force_enabled: "force_enabled x ∈ measurable S S"
proof (rule measurable_stream_space2)
fix n show "(λω. force_enabled x ω !! n) ∈ measurable S (count_space UNIV)"
proof (induction n arbitrary: x)
case (Suc n) show ?case
apply simp
apply (rule measurable_compose_countable'[OF measurable_compose[OF measurable_stl Suc], where I="set_pmf (K x)"])
apply (rule measurable_compose[OF measurable_shd])
apply (auto simp: countable_set_pmf some_in_eq set_pmf_not_empty)
done
qed (auto intro!: measurable_compose[OF measurable_shd])
qed
abbreviation "D ≡ stream_space (Π⇩M s∈UNIV. K s)"
lemma sets_D: "sets D = sets (stream_space (Π⇩M s∈UNIV. count_space UNIV))"
by (intro sets_stream_space_cong sets_PiM_cong) simp_all
lemma space_D: "space D = space (stream_space (Π⇩M s∈UNIV. count_space UNIV))"
using sets_eq_imp_space_eq[OF sets_D] .
lemma measurable_D_D: "measurable D D =
measurable (stream_space (Π⇩M s∈UNIV. count_space UNIV)) (stream_space (Π⇩M s∈UNIV. count_space UNIV))"
by (simp add: measurable_def space_D sets_D)
primcorec walk :: "'s ⇒ ('s ⇒ 's) stream ⇒ 's stream" where
"shd (walk s ω) = (if shd ω s ∈ K s then shd ω s else (SOME t. t ∈ K s))"
| "stl (walk s ω) = walk (if shd ω s ∈ K s then shd ω s else (SOME t. t ∈ K s)) (stl ω)"
lemma enabled_walk: "enabled s (walk s ω)"
by (coinduction arbitrary: s ω) (auto simp: some_in_eq set_pmf_not_empty)
lemma measurable_walk[measurable]: "walk s ∈ measurable D S"
proof -
note measurable_compose[OF measurable_snth, intro!]
note measurable_compose[OF measurable_component_singleton, intro!]
note if_weak_cong[cong del]
note measurable_g = measurable_compose_countable'[OF _ _ countable_reachable]
define n :: nat where "n = 0"
define g where "g = (λ_::('s ⇒ 's) stream. s)"
then have "g ∈ measurable D (count_space (acc `` {s}))"
by auto
then have "(λx. walk (g x) (sdrop n x)) ∈ measurable D S"
proof (coinduction arbitrary: g n rule: measurable_stream_coinduct)
case (shd g) show ?case
by (fastforce intro: measurable_g[OF _ shd])
next
case (stl g) show ?case
by (fastforce simp add: sdrop.simps[symmetric] some_in_eq set_pmf_not_empty
simp del: sdrop.simps intro: rtrancl_into_rtrancl measurable_g[OF _ stl])
qed
then show ?thesis
by (simp add: g_def n_def)
qed
subsection ‹Trace Space for Discrete-Time Markov Chains›
definition T :: "'s ⇒ 's stream measure" where
"T s = distr (stream_space (Π⇩M s∈UNIV. K s)) S (walk s)"
lemma space_T[simp]: "space (T s) = space S"
by (simp add: T_def)
lemma sets_T[simp, measurable_cong]: "sets (T s) = sets S"
by (simp add: T_def)
lemma measurable_T1[simp]: "measurable (T s) M = measurable S M"
by (intro measurable_cong_sets) simp_all
lemma measurable_T2[simp]: "measurable M (T s) = measurable M S"
by (intro measurable_cong_sets) simp_all
lemma in_measurable_T1[measurable (raw)]: "f ∈ measurable S M ⟹ f ∈ measurable (T s) M"
by simp
lemma in_measurable_T2[measurable (raw)]: "f ∈ measurable M S ⟹ f ∈ measurable M (T s)"
by simp
lemma AE_T_enabled: "AE ω in T s. enabled s ω"
unfolding T_def by (simp add: AE_distr_iff enabled_walk)
sublocale T: prob_space "T s" for s
proof -
interpret P: product_prob_space K UNIV ..
interpret prob_space "stream_space (Π⇩M s∈UNIV. K s)"
by (rule P.prob_space_stream_space)
fix s show "prob_space (T s)"
by (simp add: T_def prob_space_distr)
qed
lemma emeasure_T_const[simp]: "emeasure (T s) (space S) = 1"
using T.emeasure_space_1[of s] by simp
lemma nn_integral_T:
assumes f[measurable]: "f ∈ borel_measurable S"
shows "(∫⇧+X. f X ∂T s) = (∫⇧+t. (∫⇧+ω. f (t ## ω) ∂T t) ∂K s)"
proof -
interpret product_prob_space K UNIV ..
interpret D: prob_space "stream_space (Π⇩M s∈UNIV. K s)"
by (rule prob_space_stream_space)
have T: "⋀f s. f ∈ borel_measurable S ⟹ (∫⇧+X. f X ∂T s) = (∫⇧+ω. f (walk s ω) ∂D)"
by (simp add: T_def nn_integral_distr)
have "(∫⇧+X. f X ∂T s) = (∫⇧+ω. f (walk s ω) ∂D)"
by (rule T) measurable
also have "… = (∫⇧+d. ∫⇧+ω. f (walk s (d ## ω)) ∂D ∂Π⇩M i∈UNIV. K i)"
by (simp add: P.nn_integral_stream_space)
also have "… = (∫⇧+d. (∫⇧+ω. f (d s ## walk (d s) ω) * indicator {t. t ∈ K s} (d s) ∂D) ∂Π⇩M i∈UNIV. K i)"
apply (rule nn_integral_cong_AE)
apply (subst walk.ctr)
apply (simp cong del: if_weak_cong)
apply (intro UNIV_I AE_component)
apply (auto simp: AE_measure_pmf_iff)
done
also have "… = (∫⇧+d. ∫⇧+ω. f (d s ## ω) * indicator (K s) (d s) ∂T (d s) ∂Π⇩M i∈UNIV. K i)"
by (subst T) (simp_all split: split_indicator)
also have "… = (∫⇧+t. ∫⇧+ω. f (t ## ω) * indicator (K s) t ∂T t ∂K s)"
by (subst (2) PiM_component[symmetric]) (simp_all add: nn_integral_distr)
also have "… = (∫⇧+t. ∫⇧+ω. f (t ## ω) ∂T t ∂K s)"
by (rule nn_integral_cong_AE) (simp add: AE_measure_pmf_iff)
finally show ?thesis .
qed
lemma nn_integral_T_gfp:
fixes g
defines "l ≡ λf ω. g (shd ω) (f (stl ω))"
assumes [measurable]: "case_prod g ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
assumes cont_g[THEN inf_continuous_compose, order_continuous_intros]: "⋀s. inf_continuous (g s)"
assumes int_g: "⋀f s. f ∈ borel_measurable S ⟹ (∫⇧+ω. g s (f ω) ∂T s) = g s (∫⇧+ω. f ω ∂T s)"
assumes bnd_g: "⋀f s. g s f ≤ b" "0 ≤ b" "b < ∞"
shows "(∫⇧+ω. gfp l ω ∂T s) = gfp (λf s. ∫⇧+t. g t (f t) ∂K s) s"
proof (rule nn_integral_gfp)
show "⋀s. sets (T s) = sets S" "⋀F. F ∈ borel_measurable S ⟹ l F ∈ borel_measurable S"
by (auto simp: l_def)
show "⋀s. emeasure (T s) (space (T s)) ≠ 0"
by (rewrite T.emeasure_space_1) simp
{ fix s F
have "integral⇧N (T s) (l F) ≤ (∫⇧+x. b ∂T s)"
by (intro nn_integral_mono) (simp add: l_def bnd_g)
also have "… < ∞"
using bnd_g by simp
finally show "integral⇧N (T s) (l F) < ∞" . }
show "inf_continuous (λf s. ∫⇧+ t. g t (f t) ∂K s)"
proof (intro order_continuous_intros)
fix f s
have "(∫⇧+ t. g t (f t) ∂K s) ≤ (∫⇧+ t. b ∂K s)"
by (intro nn_integral_mono bnd_g)
also have "… < ∞"
using bnd_g by simp
finally show "(∫⇧+ t. g t (f t) ∂K s) ≠ ∞"
by simp
qed simp
next
fix s and F :: "'s stream ⇒ ennreal" assume "F ∈ borel_measurable S"
then show "integral⇧N (T s) (l F) = (∫⇧+ t. g t (integral⇧N (T t) F) ∂K s) "
by (rewrite nn_integral_T) (simp_all add: l_def int_g)
qed (auto intro!: order_continuous_intros simp: l_def)
lemma nn_integral_T_lfp:
fixes g
defines "l ≡ λf ω. g (shd ω) (f (stl ω))"
assumes [measurable]: "case_prod g ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
assumes cont_g[THEN sup_continuous_compose, order_continuous_intros]: "⋀s. sup_continuous (g s)"
assumes int_g: "⋀f s. f ∈ borel_measurable S ⟹ (∫⇧+ω. g s (f ω) ∂T s) = g s (∫⇧+ω. f ω ∂T s)"
shows "(∫⇧+ω. lfp l ω ∂T s) = lfp (λf s. ∫⇧+t. g t (f t) ∂K s) s"
proof (rule nn_integral_lfp)
show "⋀s. sets (T s) = sets S" "⋀F. F ∈ borel_measurable S ⟹ l F ∈ borel_measurable S"
by (auto simp: l_def)
next
fix s and F :: "'s stream ⇒ ennreal" assume "F ∈ borel_measurable S"
then show "integral⇧N (T s) (l F) = (∫⇧+ t. g t (integral⇧N (T t) F) ∂K s) "
by (rewrite nn_integral_T) (simp_all add: l_def int_g)
qed (auto simp: l_def intro!: order_continuous_intros)
lemma emeasure_Collect_T:
assumes f[measurable]: "Measurable.pred S P"
shows "emeasure (T s) {x∈space (T s). P x} = (∫⇧+t. emeasure (T t) {x∈space (T t). P (t ## x)} ∂K s)"
apply (subst (1 2) nn_integral_indicator[symmetric])
apply simp
apply simp
apply (subst nn_integral_T)
apply (auto intro!: nn_integral_cong simp add: space_stream_space indicator_def)
done
lemma AE_T_iff:
assumes [measurable]: "Measurable.pred S P"
shows "(AE ω in T x. P ω) ⟷ (∀y∈K x. AE ω in T y. P (y ## ω))"
by (simp add: AE_iff_nn_integral nn_integral_T[where s=x])
(auto simp add: nn_integral_0_iff_AE AE_measure_pmf_iff split: split_indicator)
lemma AE_T_alw:
assumes [measurable]: "Measurable.pred S P"
assumes P: "⋀s. (x, s) ∈ acc ⟹ AE ω in T s. P ω"
shows "AE ω in T x. alw P ω"
proof -
define F where "F = (λp x. P x ∧ p (stl x))"
have [measurable]: "⋀p. Measurable.pred S p ⟹ Measurable.pred S (F p)"
by (auto simp: F_def)
have "almost_everywhere (T s) ((F ^^ i) top)"
if "(x, s) ∈ acc" for i s
using that
proof (induction i arbitrary: s)
case (Suc i) then show ?case
apply simp
apply (subst F_def)
apply (simp add: P)
apply (subst AE_T_iff)
apply (measurable; simp)
apply (auto dest: rtrancl_into_rtrancl)
done
qed simp
then have "almost_everywhere (T x) (gfp F)"
by (subst inf_continuous_gfp) (auto simp: inf_continuous_def AE_all_countable F_def)
then show ?thesis
by (simp add: alw_def F_def)
qed
lemma emeasure_suntil_disj:
assumes [measurable]: "Measurable.pred S P"
assumes *: "⋀t. AE ω in T t. ¬ (P ⊓ (HLD X ⊓ nxt (HLD X suntil P))) ω"
shows "emeasure (T s) {ω∈space (T s). (HLD X suntil P) ω} =
lfp (λF s. emeasure (T s) {ω∈space (T s). P ω} + (∫⇧+t. F t * indicator X t ∂K s)) s"
unfolding suntil_lfp
proof (rule emeasure_lfp[where s=s])
fix F t assume [measurable]: "Measurable.pred (T s) F" and
F: "F ≤ lfp (λa b. P b ∨ HLD X b ∧ a (stl b))"
have "emeasure (T t) {ω ∈ space (T s). P ω ∨ HLD X ω ∧ F (stl ω)} =
emeasure (T t) {ω ∈ space (T t). P ω} + emeasure (T t) {ω∈space (T t). HLD X ω ∧ F (stl ω)}"
proof (rule emeasure_add_AE)
show "AE x in T t. ¬ (x ∈ {ω ∈ space (T t). P ω} ∧ x ∈ {ω ∈ space (T t). HLD X ω ∧ F (stl ω)})"
using * by eventually_elim (insert F, auto simp: suntil_lfp[symmetric])
qed auto
also have "emeasure (T t) {ω∈space (T t). HLD X ω ∧ F (stl ω)} =
(∫⇧+t. emeasure (T t) {ω ∈ space (T s). F ω} * indicator X t ∂K t)"
by (subst emeasure_Collect_T) (auto intro!: nn_integral_cong split: split_indicator)
finally show "emeasure (T t) {ω ∈ space (T s). P ω ∨ HLD X ω ∧ F (stl ω)} =
emeasure (T t) {ω ∈ space (T t). P ω} + (∫⇧+ t. emeasure (T t) {ω ∈ space (T s). F ω} * indicator X t ∂K t)" .
qed (auto intro!: order_continuous_intros split: split_indicator)
lemma emeasure_HLD_nxt:
assumes [measurable]: "Measurable.pred S P"
shows "emeasure (T s) {ω∈space (T s). (X ⋅ P) ω} =
(∫⇧+x. emeasure (T x) {ω∈space (T x). P ω} * indicator X x ∂K s)"
by (subst emeasure_Collect_T)
(auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff split: split_indicator)
lemma emeasure_HLD:
"emeasure (T s) {ω∈space (T s). HLD X ω} = emeasure (K s) X"
using emeasure_HLD_nxt[of "λω. True" s X] T.emeasure_space_1 by simp
lemma emeasure_suntil_HLD:
assumes [measurable]: "Measurable.pred S P"
shows "emeasure (T s) {x∈space (T s). (not (HLD {t}) suntil (HLD {t} aand nxt P)) x} =
emeasure (T s) {x∈space (T s). ev (HLD {t}) x} * emeasure (T t) {x∈space (T t). P x}"
proof -
let ?P = "emeasure (T t) {ω∈space (T t). P ω}"
let ?F = "λQ F s. emeasure (T s) {ω∈space (T s). Q ω} + (∫⇧+t'. F t' * indicator (- {t}) t' ∂K s)"
have "emeasure (T s) {x∈space (T s). (HLD (-{t}) suntil ({t} ⋅ P)) x} = lfp (?F ({t} ⋅ P)) s"
by (rule emeasure_suntil_disj) (auto simp: HLD_iff)
also have "lfp (?F ({t} ⋅ P)) = (λs. lfp (?F (HLD {t})) s * ?P)"
proof (rule lfp_transfer[symmetric, where α="λx s. x s * emeasure (T t) {ω∈space (T t). P ω}"])
fix F show "(λs. ?F (HLD {t}) F s * ?P) = ?F ({t} ⋅ P) (λs. F s * ?P)"
unfolding emeasure_HLD emeasure_HLD_nxt[OF assms] distrib_right
by (auto simp: fun_eq_iff nn_integral_multc[symmetric]
intro!: arg_cong2[where f="(+)"] nn_integral_cong ac_simps
split: split_indicator)
qed (auto intro!: order_continuous_intros sup_continuous_mono lfp_upperbound
intro: le_funI add_nonneg_nonneg
simp: bot_ennreal split: split_indicator)
also have "lfp (?F (HLD {t})) s = emeasure (T s) {x∈space (T s). (HLD (-{t}) suntil HLD {t}) x}"
by (rule emeasure_suntil_disj[symmetric]) (auto simp: HLD_iff)
finally show ?thesis
by (simp add: HLD_iff[abs_def] ev_eq_suntil)
qed
lemma AE_suntil:
assumes [measurable]: "Measurable.pred S P"
shows "(AE x in T s. (not (HLD {t}) suntil (HLD {t} aand nxt P)) x) ⟷
(AE x in T s. ev (HLD {t}) x) ∧ (AE x in T t. P x)"
apply (subst (1 2 3) T.prob_Collect_eq_1[symmetric])
apply simp
apply simp
apply simp
apply (simp_all add: measure_def emeasure_suntil_HLD del: space_T nxt.simps)
apply (auto simp: T.emeasure_eq_measure mult_eq_1)
done
subsection ‹Fairness›
definition fair :: "'s ⇒ 's ⇒ 's stream ⇒ bool" where
"fair s t = alw (ev (HLD {s})) impl alw (ev (HLD {s} aand nxt (HLD {t})))"
lemma AE_T_fair:
assumes "t' ∈ K t"
shows "AE ω in T s. fair t t' ω"
proof -
let ?M = "λP s. emeasure (T s) {ω∈space (T s). P ω}"
let ?t = "HLD {t}" and ?t' = "HLD {t'}"
define N where "N = alw (ev ?t) aand alw (not (?t aand nxt ?t'))"
let ?until = "not ?t suntil (?t aand nxt (not ?t' aand nxt N))"
have N_stl: "⋀ω. N ω ⟹ N (stl ω)"
by (auto simp: N_def)
have [measurable]: "Measurable.pred S N"
unfolding N_def by measurable
let ?c = "pmf (K t) t'"
let ?R = "λx. 1 ⊓ x * (1 - ennreal ?c)"
have "mono ?R"
by (intro monoI mult_right_mono inf_mono) (auto simp: mono_def field_simps )
have "⋀s. ?M N s ≤ gfp ?R"
proof (induction rule: gfp_ordinal_induct[OF ‹mono ?R›])
fix x s assume x: "⋀s. ?M N s ≤ x"
{ fix ω assume "N ω"
then have "ev (HLD {t}) ω" "N ω"
by (auto simp: N_def)
then have "?until ω"
by (induct rule: ev_induct_strong) (auto simp: N_def intro: suntil.intros dest: N_stl) }
then have "?M N s ≤ ?M ?until s"
by (intro emeasure_mono_AE) auto
also have "… = ?M (ev ?t) s * ?M (not ?t' aand nxt N) t"
by (simp_all add: emeasure_suntil_HLD del: nxt.simps space_T)
also have "… ≤ ?M (ev ?t) s * (∫⇧+s'. 1 ⊓ x * indicator (UNIV - {t'}) s' ∂K t)"
by (auto intro!: mult_left_mono nn_integral_mono T.measure_le_1 emeasure_mono
split: split_indicator simp add: x emeasure_Collect_T[of _ t] simp del: space_T)
also have "… ≤ 1 * (∫⇧+s'. 1 ⊓ x * indicator (UNIV - {t'}) s' ∂K t)"
by (intro mult_right_mono T.measure_le_1) simp
finally show "?M N s ≤ 1 ⊓ x * (1 - ennreal ?c)"
by (subst (asm) nn_integral_cmult_indicator) (auto simp: emeasure_Diff emeasure_pmf_single)
qed (auto intro: Inf_greatest)
also
from ‹mono ?R› have "gfp ?R = ?R (gfp ?R)" by (rule gfp_unfold)
then have "gfp ?R ≤ ?R (gfp ?R)" by simp
with assms[THEN pmf_positive] have "gfp ?R ≤ 0"
by (cases "gfp ?R")
(auto simp: top_unique inf_ennreal.rep_eq field_simps mult_le_0_iff ennreal_1[symmetric]
pmf_le_1 ennreal_minus ennreal_mult[symmetric] ennreal_le_iff2 inf_min min_def
simp del: ennreal_1
split: if_split_asm)
finally have "⋀s. AE ω in T s. ¬ N ω"
by (subst AE_iff_measurable[OF _ refl]) (auto intro: antisym simp: le_fun_def)
then have "AE ω in T s. alw (not N) ω"
by (intro AE_T_alw) auto
moreover
{ fix ω assume "alw (ev (HLD {t})) ω"
then have "alw (alw (ev (HLD {t}))) ω"
unfolding alw_alw .
moreover assume "alw (not N) ω"
then have "alw (alw (ev (HLD {t})) impl ev (HLD {t} aand nxt (HLD {t'}))) ω"
unfolding N_def not_alw_iff not_ev_iff de_Morgan_disj de_Morgan_conj not_not imp_conv_disj .
ultimately have "alw (ev (HLD {t} aand nxt (HLD {t'}))) ω"
by (rule alw_mp) }
then have "∀ω. alw (not N) ω ⟶ fair t t' ω"
by (auto simp: fair_def)
ultimately show ?thesis
by (simp add: eventually_mono)
qed
lemma enabled_imp_trancl:
assumes "alw (HLD B) ω" "enabled s ω"
shows "alw (HLD (acc_on B `` {s})) ω"
proof -
define t where "t = s"
then have "(s, t) ∈ acc_on B"
by auto
moreover note ‹alw (HLD B) ω›
moreover note ‹enabled s ω›[unfolded ‹t == s›[symmetric]]
ultimately show ?thesis
proof (coinduction arbitrary: t ω rule: alw_coinduct)
case stl from this(1,2,3) show ?case
by (auto simp: enabled.simps[of _ ω] alw.simps[of _ ω] HLD_iff
intro!: exI[of _ "shd ω"] rtrancl_trans[of s t])
next
case (alw t ω) then show ?case
by (auto simp: HLD_iff enabled.simps[of _ ω] alw.simps[of _ ω] intro!: rtrancl_trans[of s t])
qed
qed
lemma AE_T_reachable: "AE ω in T s. alw (HLD (acc `` {s})) ω"
using AE_T_enabled
proof eventually_elim
fix ω assume "enabled s ω"
from enabled_imp_trancl[of UNIV, OF _ this]
show "alw (HLD (acc `` {s})) ω"
by (auto simp: HLD_iff[abs_def] all_imp_alw)
qed
lemma AE_T_all_fair: "AE ω in T s. ∀(t,t')∈SIGMA t:UNIV. K t. fair t t' ω"
proof -
let ?Rn = "SIGMA s:(acc `` {s}). K s"
have "AE ω in T s. ∀(t,t')∈?Rn. fair t t' ω"
proof (subst AE_ball_countable)
show "countable ?Rn"
by (intro countable_SIGMA countable_rtrancl[OF countable_Image]) (auto simp: Image_def)
qed (auto intro!: AE_T_fair)
then show ?thesis
using AE_T_reachable
proof (eventually_elim, safe)
fix ω t t' assume "∀(t,t')∈?Rn. fair t t' ω" "t' ∈ K t" and alw: "alw (HLD (acc `` {s})) ω"
moreover
{ assume "t ∉ acc `` {s}"
then have "alw (not (HLD {t})) ω"
by (intro alw_mono[OF alw]) (auto simp: HLD_iff)
then have "not (alw (ev (HLD {t}))) ω"
unfolding not_alw_iff not_ev_iff by auto
then have "fair t t' ω"
unfolding fair_def by auto }
ultimately show "fair t t' ω"
by auto
qed
qed
lemma fair_imp: assumes "fair t t' ω" "alw (ev (HLD {t})) ω" shows "alw (ev (HLD {t'})) ω"
proof -
{ fix ω assume "ev (HLD {t} aand nxt (HLD {t'})) ω" then have "ev (HLD {t'}) ω"
by induction auto }
with assms show ?thesis
by (auto simp: fair_def elim!: alw_mp intro: all_imp_alw)
qed
lemma AE_T_ev_HLD:
assumes exiting: "⋀t. (s, t) ∈ acc_on (-B) ⟹ ∃t'∈B. (t, t') ∈ acc"
assumes fin: "finite (acc_on (-B) `` {s})"
shows "AE ω in T s. ev (HLD B) ω"
using AE_T_all_fair AE_T_enabled
proof eventually_elim
fix ω assume fair: "∀(t, t')∈(SIGMA s:UNIV. K s). fair t t' ω" and "enabled s ω"
show "ev (HLD B) ω"
proof (rule ccontr)
assume "¬ ev (HLD B) ω"
then have "alw (HLD (- B)) ω"
by (simp add: not_ev_iff HLD_iff[abs_def])
from enabled_imp_trancl[OF this ‹enabled s ω›]
have "alw (HLD (acc_on (-B) `` {s})) ω"
by (simp add: Diff_eq)
from pigeonhole_stream[OF this fin]
obtain t where "(s, t) ∈ acc_on (-B)" "alw (ev (HLD {t})) ω"
by auto
from exiting[OF this(1)] obtain t' where "(t, t') ∈ acc" "t' ∈ B"
by auto
from this(1) have "alw (ev (HLD {t'})) ω"
proof induction
case (step u w) then show ?case
using fair fair_imp[of u w ω] by auto
qed fact
{ assume "ev (HLD {t'}) ω" then have "ev (HLD B) ω"
by (rule ev_mono) (auto simp: HLD_iff ‹t' ∈ B›) }
then show False
using ‹alw (ev (HLD {t'})) ω› ‹¬ ev (HLD B) ω› by auto
qed
qed
lemma AE_T_ev_HLD':
assumes exiting: "⋀s. s ∉ X ⟹ ∃t∈X. (s, t) ∈ acc"
assumes fin: "finite (-X)"
shows "AE ω in T s. ev (HLD X) ω"
proof (rule AE_T_ev_HLD)
show "⋀t. (s, t) ∈ acc_on (- X) ⟹ ∃t'∈X. (t, t') ∈ acc"
using exiting by (auto elim: rtrancl.cases)
have "acc_on (- X) `` {s} ⊆ -X ∪ {s}"
by (auto elim: rtrancl.cases)
with fin show "finite (acc_on (- X) `` {s})"
by (auto dest: finite_subset )
qed
lemma AE_T_max_sfirst:
assumes [measurable]: "Measurable.pred S X"
assumes AE: "AE ω in T c. sfirst X (c ## ω) < ∞" and "0 < e"
shows "∃N::nat. 𝒫(ω in T c. N < sfirst X (c ## ω)) < e" (is "∃N. ?P N < e")
proof -
have "?P ⇢ measure (T c) (⋂N::nat. {bT ∈ space (T c). N < sfirst X (c ## bT)})"
using dual_order.strict_trans enat_ord_simps(2)
by (intro T.finite_Lim_measure_decseq) (force simp: decseq_Suc_iff simp del: enat_ord_simps)+
also have "measure (T c) (⋂N::nat. {bT ∈ space (T c). N < sfirst X (c ## bT)}) =
𝒫(bT in T c. sfirst X (c ## bT) = ∞)"
by (auto simp del: not_infinity_eq intro!: arg_cong[where f="measure (T c)"])
(metis less_irrefl not_infinity_eq)
also have "𝒫(bT in T c. sfirst X (c ## bT) = ∞) = 0"
using AE by (intro T.prob_eq_0_AE) auto
finally have "∃N. ∀n≥N. norm (?P n - 0) < e"
using ‹0 < e› by (rule LIMSEQ_D)
then show ?thesis
by (auto simp: measure_nonneg)
qed
subsection ‹First Hitting Time›
lemma nn_integral_sfirst_finite':
assumes "s ∉ H"
assumes [simp]: "finite (acc_on (-H) `` {s})"
assumes until: "AE ω in T s. ev (HLD H) ω"
shows "(∫⇧+ ω. sfirst (HLD H) ω ∂T s) ≠ ∞"
proof -
have R_ne[simp]: "acc_on (-H) `` {s} ≠ {}"
by auto
have [measurable]: "H ∈ sets (count_space UNIV)"
by simp
let ?Pf = "λn t. 𝒫(ω in T t. enat n < sfirst (HLD H) (t ## ω))"
have Pf_mono: "⋀N n t. N ≤ n ⟹ ?Pf n t ≤ ?Pf N t"
by (auto intro!: T.finite_measure_mono simp del: enat_ord_code(1) simp: enat_ord_code(1)[symmetric])
have not_H: "⋀t. (s, t) ∈ acc_on (-H) ⟹ t ∉ H"
using ‹s ∉ H› by (auto elim: rtrancl.cases)
have "∀⇩F n in sequentially. ∀t∈acc_on (-H)``{s}. ?Pf n t < 1"
proof (safe intro!: eventually_ball_finite)
fix t assume "(s, t) ∈ acc_on (-H)"
then have "AE ω in T t. sfirst (HLD H) (t ## ω) < ∞"
unfolding sfirst_finite
proof induction
case (step t u) with step.IH show ?case
by (subst (asm) AE_T_iff) (auto simp: ev_Stream not_H)
qed (simp add: ev_Stream eventually_frequently_simps until)
from AE_T_max_sfirst[OF _ this, of 1]
obtain N where "?Pf N t < 1" by auto
with Pf_mono[of N] show "∀⇩F n in sequentially. ?Pf n t < 1"
by (auto simp: eventually_sequentially intro: le_less_trans)
qed simp
then obtain n where "⋀t. (s, t) ∈ acc_on (-H) ⟹ ?Pf n t < 1"
by (auto simp: eventually_sequentially)
moreover define d where "d = Max (?Pf n ` acc_on (-H) `` {s})"
ultimately have d: "0 ≤ d" "d < 1" "⋀t. (s, t) ∈ acc_on (-H) ⟹ ?Pf (Suc n) t ≤ d"
using Pf_mono[of n "Suc n"] by (auto simp: Max_ge_iff measure_nonneg)
let ?F = "λF ω. if shd ω ∈ H then 0 else F (stl ω) + 1 :: ennreal"
have "sup_continuous ?F"
by (intro order_continuous_intros)
then have "mono ?F"
by (rule sup_continuous_mono)
have lfp_nonneg[simp]: "⋀ω. 0 ≤ lfp ?F ω"
by (subst lfp_unfold[OF ‹mono ?F›]) auto
let ?I = "λF s. ∫⇧+t. (if t ∈ H then 0 else F t + 1) ∂K s"
have "sup_continuous ?I"
by (intro order_continuous_intros) auto
then have "mono ?I"
by (rule sup_continuous_mono)
define p where "p = Suc n / (1 - d)"
have p: "p = Suc n + d * p"
unfolding p_def using d(1,2) by (auto simp: field_simps)
have [simp]: "0 ≤ p"
using d(1,2) by (auto simp: p_def)
have "(∫⇧+ ω. sfirst (HLD H) ω ∂T s) = (∫⇧+ ω. lfp ?F ω ∂T s)"
proof (intro nn_integral_cong_AE)
show "AE x in T s. sfirst (HLD H) x = lfp ?F x"
using until
proof eventually_elim
fix ω assume "ev (HLD H) ω" then show "sfirst (HLD H) ω = lfp ?F ω"
by (induction rule: ev_induct_strong;
subst lfp_unfold[OF ‹mono ?F›], simp add: HLD_iff[abs_def] ac_simps max_absorb2)
qed
qed
also have "… = lfp (?I^^Suc n) s"
unfolding lfp_funpow[OF ‹mono ?I›]
by (subst nn_integral_T_lfp)
(auto simp: nn_integral_add max_absorb2 intro!: order_continuous_intros)
also have "lfp (?I^^Suc n) t ≤ p" if "(s, t) ∈ acc_on (-H)" for t
using that
proof (induction arbitrary: t rule: lfp_ordinal_induct[of "?I^^Suc n"])
case (step S)
have "(?I^^i) S t ≤ i + ?Pf i t * ennreal p" for i
using step(3)
proof (induction i arbitrary: t)
case 0 then show ?case
using T.prob_space step(1)
by (auto simp add: zero_ennreal_def[symmetric] not_H zero_enat_def[symmetric] one_ennreal_def[symmetric])
next
case (Suc i)
then have "t ∉ H"
by (auto simp: not_H)
from Suc.prems have "⋀t'. t' ∈ K t ⟹ t' ∉ H ⟹ (s, t') ∈ acc_on (-H)"
by (rule rtrancl_into_rtrancl) (insert Suc.prems, auto dest: not_H)
then have "(?I ^^ Suc i) S t ≤ ?I (λt. i + ennreal (?Pf i t) * p) t"
by (auto simp: AE_measure_pmf_iff simp del: sfirst_eSuc space_T
intro!: nn_integral_mono_AE add_mono max.mono Suc)
also have "… ≤ (∫⇧+ t. ennreal (Suc i) + ennreal 𝒫(ω in T t. enat i < sfirst (HLD H) (t ## ω)) * p ∂K t)"
by (intro nn_integral_mono) auto
also have "… ≤ Suc i + ennreal (?Pf (Suc i) t) * p"
unfolding T.emeasure_eq_measure[symmetric]
by (subst (2) emeasure_Collect_T)
(auto simp: ‹t ∉ H› eSuc_enat[symmetric] nn_integral_add nn_integral_multc ennreal_of_nat_eq_real_of_nat)
finally show ?case
by (simp add: ennreal_of_nat_eq_real_of_nat)
qed
then have "(?I^^Suc n) S t ≤ Suc n + ?Pf (Suc n) t * ennreal p" .
also have "… ≤ p"
using d step by (subst (2) p) (auto intro!: mult_right_mono simp: ennreal_of_nat_eq_real_of_nat ennreal_mult)
finally show ?case .
qed (auto simp: SUP_least intro!: mono_pow ‹mono ?I› simp del: funpow.simps)
finally show ?thesis
unfolding p_def by (auto simp: top_unique)
qed
lemma nn_integral_sfirst_finite:
assumes [simp]: "finite (acc_on (-H) `` {s})"
assumes until: "AE ω in T s. ev (HLD H) ω"
shows "(∫⇧+ ω. sfirst (HLD H) (s ## ω) ∂T s) ≠ ∞"
proof cases
assume "s ∉ H" then show ?thesis
using nn_integral_sfirst_finite'[of s H] until by (simp add: nn_integral_add)
qed (simp add: sfirst.simps)
lemma prob_T:
assumes P: "Measurable.pred S P"
shows "𝒫(ω in T s. P ω) = (∫t. 𝒫(ω in T t. P (t ## ω)) ∂K s)"
using emeasure_Collect_T[OF P, of s] unfolding T.emeasure_eq_measure
by (subst (asm) nn_integral_eq_integral)
(auto intro!: measure_pmf.integrable_const_bound[where B=1])
lemma T_subprob[measurable]: "T ∈ measurable (measure_pmf I) (subprob_algebra S)"
by (auto intro!: space_bind simp: space_subprob_algebra) unfold_locales
subsection ‹Markov chain with Initial Distribution›
definition T' :: "'s pmf ⇒ 's stream measure" where
"T' I = bind I (λs. distr (T s) S ((##) s))"
lemma distr_Stream_subprob:
"(λs. distr (T s) S ((##) s)) ∈ measurable (measure_pmf I) (subprob_algebra S)"
apply (intro measurable_distr2[OF _ T_subprob])
apply (subst measurable_cong_sets[where M'="count_space UNIV ⨂⇩M S" and N'=S])
apply (rule sets_pair_measure_cong)
apply auto
done
lemma sets_T': "sets (T' I) = sets S"
by (simp add: T'_def)
lemma prob_space_T': "prob_space (T' I)"
unfolding T'_def
proof (rule measure_pmf.prob_space_bind)
show "AE s in I. prob_space (distr (T s) S ((##) s))"
by (intro AE_measure_pmf_iff[THEN iffD2] ballI T.prob_space_distr) simp
qed (rule distr_Stream_subprob)
lemma AE_T':
assumes [measurable]: "Measurable.pred S P"
shows "(AE x in T' I. P x) ⟷ (∀s∈I. AE x in T s. P (s ## x))"
unfolding T'_def by (simp add: AE_bind[OF distr_Stream_subprob] AE_measure_pmf_iff AE_distr_iff)
lemma emeasure_T':
assumes [measurable]: "X ∈ sets S"
shows "emeasure (T' I) X = (∫⇧+s. emeasure (T s) {ω∈space S. s ## ω ∈ X} ∂I)"
unfolding T'_def
by (simp add: emeasure_bind[OF _ distr_Stream_subprob] emeasure_distr vimage_def Int_def conj_ac)
lemma prob_T':
assumes [measurable]: "Measurable.pred S P"
shows "𝒫(x in T' I. P x) = (∫s. 𝒫(x in T s. P (s ## x)) ∂I)"
proof -
interpret T': prob_space "T' I" by (rule prob_space_T')
show ?thesis
using emeasure_T'[of "{x∈space (T' I). P x}" I]
unfolding T'.emeasure_eq_measure T.emeasure_eq_measure sets_eq_imp_space_eq[OF sets_T']
apply simp
apply (subst (asm) nn_integral_eq_integral)
apply (auto intro!: measure_pmf.integrable_const_bound[where B=1] integral_cong arg_cong2[where f=measure]
simp: AE_measure_pmf measure_nonneg space_stream_space)
done
qed
lemma T_eq_T': "T s = T' (K s)"
proof (rule measure_eqI)
fix X assume X: "X ∈ sets (T s)"
then have [measurable]: "X ∈ sets S"
by simp
have X_eq: "X = {x∈space (T s). x ∈ X}"
using sets.sets_into_space[OF X] by auto
show "emeasure (T s) X = emeasure (T' (K s)) X"
apply (subst X_eq)
apply (subst emeasure_Collect_T, simp)
apply (subst emeasure_T', simp)
apply simp
done
qed (simp add: sets_T')
lemma T_eq_bind: "T s = (measure_pmf (K s) ⤜ (λt. distr (T t) S ((##) t)))"
by (subst T_eq_T') (simp add: T'_def)
lemma T_split:
"T s = (T s ⤜ (λω. distr (T ((s ## ω) !! n)) S (λω'. stake n ω @- ω')))"
proof (induction n arbitrary: s)
case 0 then show ?case
apply (simp add: distr_cong[OF refl sets_T[symmetric, of s] refl])
apply (subst bind_const')
apply unfold_locales
..
next
case (Suc n)
let ?K = "measure_pmf (K s)" and ?m = "λn ω ω'. stake n ω @- ω'"
note sets_stream_space_cong[simp, measurable_cong]
have "T s = (?K ⤜ (λt. distr (T t) S ((##) t)))"
by (rule T_eq_bind)
also have "… = (?K ⤜ (λt. distr (T t ⤜ (λω. distr (T ((t ## ω) !! n)) S (?m n ω))) S ((##) t)))"
unfolding Suc[symmetric] ..
also have "… = (?K ⤜ (λt. T t ⤜ (λω. distr (distr (T ((t ## ω) !! n)) S (?m n ω)) S ((##) t))))"
by (simp add: distr_bind[where K=S, OF measurable_distr2[where M=S]] space_stream_space)
also have "… = (?K ⤜ (λt. T t ⤜ (λω. distr (T ((t ## ω) !! n)) S (?m (Suc n) (t ## ω)))))"
by (simp add: distr_distr space_stream_space comp_def)
also have "… = (?K ⤜ (λt. distr (T t) S ((##) t) ⤜ (λω. distr (T (ω !! n)) S (?m (Suc n) ω))))"
by (simp add: space_stream_space bind_distr[OF _ measurable_distr2[where M=S]] del: stake.simps)
also have "… = (T s ⤜ (λω. distr (T (ω !! n)) S (?m (Suc n) ω)))"
unfolding T_eq_bind[of s]
by (subst bind_assoc[OF measurable_distr2[where M=S] measurable_distr2[where M=S], OF _ T_subprob])
(simp_all add: space_stream_space del: stake.simps)
finally show ?case
by simp
qed
lemma nn_integral_T_split:
assumes f[measurable]: "f ∈ borel_measurable S"
shows "(∫⇧+ω. f ω ∂T s) = (∫⇧+ω. (∫⇧+ω'. f (stake n ω @- ω') ∂T ((s ## ω) !! n)) ∂T s)"
apply (subst T_split[of s n])
apply (simp add: nn_integral_bind[OF f measurable_distr2[where M=S]])
apply (subst nn_integral_distr)
apply (simp_all add: space_stream_space)
done
lemma emeasure_T_split:
assumes P[measurable]: "Measurable.pred S P"
shows "emeasure (T s) {ω∈space (T s). P ω} =
(∫⇧+ω. emeasure (T ((s ## ω) !! n)) {ω'∈space (T ((s ## ω) !! n)). P (stake n ω @- ω')} ∂T s)"
apply (subst T_split[of s n])
apply (subst emeasure_bind[OF _ measurable_distr2[where M=S]])
apply (simp_all add: )
apply (simp add: space_stream_space)
apply (subst emeasure_distr)
apply simp_all
apply (simp_all add: space_stream_space)
done
lemma prob_T_split:
assumes P[measurable]: "Measurable.pred S P"
shows "𝒫(ω in T s. P ω) = (∫ω. 𝒫(ω' in T ((s ## ω) !! n). P (stake n ω @- ω')) ∂T s)"
using emeasure_T_split[OF P, of s n]
unfolding T.emeasure_eq_measure
by (subst (asm) nn_integral_eq_integral)
(auto intro!: T.integrable_const_bound[where B=1] measure_measurable_subprob_algebra2[where N=S]
simp: T.emeasure_eq_measure SIGMA_Collect_eq)
lemma enabled_imp_alw:
"(⋃s∈X. set_pmf (K s)) ⊆ X ⟹ x ∈ X ⟹ enabled x ω ⟹ alw (HLD X) ω"
proof (coinduction arbitrary: ω x)
case alw then show ?case
unfolding enabled.simps[of _ ω]
by (auto simp: HLD_iff)
qed
lemma alw_HLD_iff_sconst:
"alw (HLD {x}) ω ⟷ ω = sconst x"
proof
assume "alw (HLD {x}) ω" then show "ω = sconst x"
by (coinduction arbitrary: ω) (auto simp: HLD_iff)
qed (auto simp: alw_sconst HLD_iff)
lemma enabled_iff_sconst:
assumes [simp]: "set_pmf (K x) = {x}" shows "enabled x ω ⟷ ω = sconst x"
proof
assume "enabled x ω" then show "ω = sconst x"
by (coinduction arbitrary: ω) (auto elim: enabled.cases)
next
assume "ω = sconst x" then show "enabled x ω"
by (coinduction arbitrary: ω) auto
qed
lemma AE_sconst:
assumes [simp]: "set_pmf (K x) = {x}"
shows "(AE ω in T x. P ω) ⟷ P (sconst x)"
proof -
have "(AE ω in T x. P ω) ⟷ (AE ω in T x. P ω ∧ ω = sconst x)"
using AE_T_enabled[of x] by (simp add: enabled_iff_sconst)
also have "… = (AE ω in T x. P (sconst x) ∧ ω = sconst x)"
by (simp del: AE_conj_iff cong: rev_conj_cong)
also have "… = (AE ω in T x. P (sconst x))"
using AE_T_enabled[of x] by (simp add: enabled_iff_sconst)
finally show ?thesis
by simp
qed
lemma ev_eq_lfp: "ev P = lfp (λF ω. P ω ∨ (¬ P ω ∧ F (stl ω)))"
unfolding ev_def by (intro antisym lfp_mono) blast+
lemma INF_eq_zero_iff_ennreal: "((⨅i∈A. f i) = (0::ennreal)) = (∀x>0. ∃i∈A. f i < x)"
using INF_eq_bot_iff[where 'a=ennreal] unfolding bot_ennreal_def zero_ennreal_def by auto
lemma inf_continuous_cmul:
fixes c :: ennreal
assumes f: "inf_continuous f" and c: "c < ⊤"
shows "inf_continuous (λx. c * f x)"
proof (rule inf_continuous_compose[OF _ f], clarsimp simp add: inf_continuous_def)
fix M :: "nat ⇒ ennreal" assume M: "decseq M"
show "c * (⨅i. M i) = (⨅i. c * M i)"
using M
by (intro LIMSEQ_unique[OF ennreal_tendsto_cmult[OF c] LIMSEQ_INF] LIMSEQ_INF)
(auto simp: decseq_def mult_left_mono)
qed
lemma AE_T_ev_HLD_infinite:
fixes X :: "'s set" and r :: real
assumes "r < 1"
assumes r: "⋀x. x ∈ X ⟹ measure (K x) X ≤ r"
shows "AE ω in T x. ev (HLD (- X)) ω"
proof -
{ fix x assume "x ∈ X"
have "0 ≤ r" using r[OF ‹x ∈ X›] measure_nonneg[of "K x" X] by (blast intro: order.trans)
define P where "P F x = ∫⇧+y. indicator X y * (F y ⊓ 1) ∂K x" for F x
have [measurable]: "X ∈ sets (count_space UNIV)" by auto
have bnd: "(∫⇧+ y. indicator X y * (f y ⊓ 1) ∂K x) ≤ 1" for x f
by (intro measure_pmf.nn_integral_le_const AE_pmfI) (auto split: split_indicator)
have "emeasure (T x) {ω∈space (T x). alw (HLD X) ω} =
emeasure (T x) {ω∈space (T x). gfp (λF ω. shd ω ∈ X ∧ F (stl ω)) ω}"
by (simp add: alw_def HLD_def)
also have "… = gfp P x"
apply (rule emeasure_gfp)
apply (auto intro!: order_continuous_intros inf_continuous_cmul split: split_indicator simp: P_def)
subgoal for x f using bnd[of x f] by (auto simp: top_unique)
subgoal for P x
apply (subst T_eq_bind)
apply (subst emeasure_bind[where N=S])
apply simp
apply (rule measurable_distr2[where M=S])
apply (auto intro: T_subprob[THEN measurable_space] intro!: nn_integral_cong_AE AE_pmfI
simp: emeasure_distr split: split_indicator)
apply (simp_all add: space_stream_space T.emeasure_le_1 inf.absorb1)
done
apply (intro le_funI)
apply (subst nn_integral_indicator[symmetric])
apply simp
apply (intro nn_integral_mono)
apply (auto split: split_indicator)
done
also have "… ≤ (INF n. ennreal r ^ n)"
proof (intro INF_greatest)
have mono_P: "mono P"
by (force simp: le_fun_def mono_def P_def intro!: nn_integral_mono intro: le_infI1 split: split_indicator)
fix n show "gfp P x ≤ ennreal r ^ n"
using ‹x ∈ X›
proof (induction n arbitrary: x)
case 0 then show ?case
by (subst gfp_unfold[OF mono_P]) (auto intro!: measure_pmf.nn_integral_le_const AE_pmfI split: split_indicator simp: P_def)
next
case (Suc n x)
have "gfp P x = P (gfp P) x" by (subst gfp_unfold[OF mono_P]) rule
also have "… ≤ P (λx. ennreal r ^ n) x"
unfolding P_def[of _ x] by (auto intro!: nn_integral_mono le_infI1 Suc split: split_indicator)
also have "… ≤ ennreal r ^ (Suc n)"
using Suc by (auto simp: P_def nn_integral_multc measure_pmf.emeasure_eq_measure intro!: mult_mono ennreal_leI r)
finally show ?case .
qed
qed
also have "… = 0"
unfolding ennreal_power[OF ‹0 ≤ r›]
proof (intro LIMSEQ_unique[OF LIMSEQ_INF])
show "decseq (λi. ennreal (r ^ i))"
using ‹0 ≤ r› ‹r < 1› by (auto intro!: ennreal_leI power_decreasing simp: decseq_def)
have "(λi. ennreal (r ^ i)) ⇢ ennreal 0"
using ‹0 ≤ r› ‹r < 1› by (intro tendsto_ennrealI LIMSEQ_power_zero) auto
then show "(λi. ennreal (r ^ i)) ⇢ 0" by simp
qed
finally have *: "emeasure (T x) {ω∈space (T x). alw (HLD X) ω} = 0" by auto
have "AE ω in T x. ev (HLD (- X)) ω"
by (rule AE_I[OF _ *]) (auto simp: not_ev_iff not_HLD[symmetric]) }
note * = this
show ?thesis
apply (clarsimp simp add: AE_T_iff[of _ x])
subgoal for x'
by (cases "x' ∈ X") (auto simp add: ev_Stream *)
done
qed
subsection ‹Trace space with Restriction›
definition "rT x = restrict_space (T x) {ω. enabled x ω}"
lemma space_rT: "ω ∈ space (rT x) ⟷ enabled x ω"
by (auto simp: rT_def space_restrict_space space_stream_space)
lemma Collect_enabled_S[measurable]: "Collect (enabled x) ∈ sets S"
proof -
have "Collect (enabled x) = {ω∈space S. enabled x ω}"
by (auto simp: space_stream_space)
then show ?thesis
by simp
qed
lemma space_rT_in_S: "space (rT x) ∈ sets S"
by (simp add: rT_def space_restrict_space)
lemma sets_rT: "A ∈ sets (rT x) ⟷ A ∈ sets S ∧ A ⊆ {ω. enabled x ω}"
by (auto simp: rT_def sets_restrict_space space_stream_space)
lemma prob_space_rT: "prob_space (rT x)"
unfolding rT_def by (auto intro!: prob_space_restrict_space T.emeasure_eq_1_AE AE_T_enabled)
lemma measurable_force_enabled2[measurable]: "force_enabled x ∈ measurable S (rT x)"
unfolding rT_def
by (rule measurable_restrict_space2)
(auto intro: measurable_force_enabled enabled_force_enabled)
lemma space_rT_not_empty[simp]: "space (rT x) ≠ {}"
by (simp add: rT_def space_restrict_space Ex_enabled)
lemma T_eq_bind': "T x = do { y ← measure_pmf (K x) ; ω ← T y ; return S (y ## ω) }"
apply (subst T_eq_bind)
apply (subst bind_return_distr[symmetric])
apply (simp_all add: space_stream_space comp_def)
done
lemma rT_eq_bind: "rT x = do { y ← measure_pmf (K x) ; ω ← rT y ; return (rT x) (y ## ω) }"
unfolding rT_def
apply (subst T_eq_bind)
apply (subst restrict_space_bind[where K=S])
apply (rule measurable_distr2[where M=S])
apply (auto simp del: measurable_pmf_measure1
simp add: Ex_enabled return_restrict_space intro!: bind_cong )
apply (subst restrict_space_bind[symmetric, where K=S])
apply (auto simp add: Ex_enabled space_restrict_space return_cong[OF sets_T]
intro!: measurable_restrict_space1 measurable_compose[OF _ return_measurable]
arg_cong2[where f=restrict_space])
apply (subst bind_return_distr[unfolded comp_def])
apply (simp add: space_restrict_space Ex_enabled)
apply (simp add: measurable_restrict_space1)
apply (rule measure_eqI)
apply simp
apply (subst (1 2) emeasure_distr)
apply (auto simp: measurable_restrict_space1)
apply (subst emeasure_restrict_space)
apply (auto simp: space_restrict_space intro!: emeasure_eq_AE)
using AE_T_enabled
apply eventually_elim
apply (simp add: space_stream_space)
apply (rule sets_Int_pred)
apply auto
apply (simp add: space_stream_space)
done
lemma snth_rT: "(λx. x !! n) ∈ measurable (rT x) (count_space (acc `` {x}))"
proof -
have "⋀ω. enabled x ω ⟹ (x, ω !! n) ∈ acc"
proof (induction n arbitrary: x)
case (Suc n) from Suc.prems Suc.IH[of "shd ω" "stl ω"] show ?case
by (auto simp: enabled.simps[of x ω] intro: rtrancl_trans)
qed (auto elim: enabled.cases)
moreover
{ fix X :: "'s set"
have [measurable]: "X ∈ count_space UNIV" by simp
have *: "(λx. x !! n) -` X ∩ space (rT x) = {ω∈space S. ω !! n ∈ X ∧ enabled x ω}"
by (auto simp: space_stream_space space_rT)
have "(λx. x !! n) -` X ∩ space (rT x) ∈ sets S"
unfolding * by measurable }
ultimately show ?thesis
by (auto simp: measurable_def space_rT sets_rT)
qed
subsection ‹Bisimulation›
lemma T_coinduct[consumes 1, case_names prob sets cont]:
assumes "R x M"
assumes prob: "⋀x M. R x M ⟹ prob_space M"
and sets: "⋀x M. R x M ⟹ sets M = sets S"
and cont': "⋀x M. R x M ⟹ ∃M'. (∀y∈K x. R y (M' y)) ∧ (∀y. sets (M' y) = S ∧ prob_space (M' y)) ∧
M = (measure_pmf (K x) ⤜ (λy. distr (M' y) S ((##) y)))"
shows "T x = M"
using ‹R x M›
proof (coinduction arbitrary: x M rule: measure_eq_stream_space_coinduct)
case left then show ?case using T.prob_space_axioms[of x] sets_T[of x] by (auto simp: space_prob_algebra)
next
case (right M) with prob[of M] sets[of M] show ?case by (auto simp: space_prob_algebra)
next
case (cont x M) with cont'[OF cont] obtain M' where *:
"(∀y∈K x. R y (M' y))"
"(∀y. sets (M' y) = S ∧ prob_space (M' y))"
"M = (measure_pmf (K x) ⤜ (λy. distr (M' y) S ((##) y)))"
by auto
show ?case
apply (rule exI[of _ T])
apply (rule exI[of _ M'])
apply (rule exI[of _ "K x"])
using * T.prob_space_axioms sets_T[of x]
apply (auto simp: space_prob_algebra intro: T_eq_bind)
done
qed
lemma T_bisim:
assumes M: "⋀x. prob_space (M x)" "⋀x. sets (M x) = sets S"
and M_eq: "⋀x. M x = (measure_pmf (K x) ⤜ (λs. distr (M s) S ((##) s)))"
shows "T = M"
proof
fix x show "T x = M x"
proof (coinduction arbitrary: x rule: T_coinduct)
case (cont x) then show ?case
apply (intro exI[of _ M])
apply (subst M_eq[of x])
apply (simp add: M)
done
qed fact+
qed
lemma T_subprob'[measurable]: "T ∈ measurable (count_space UNIV) (subprob_algebra S)"
by (auto intro!: space_bind simp: space_subprob_algebra) unfold_locales
lemma T_subprob''[simp]: "T a ∈ space (subprob_algebra S)"
using measurable_space[OF T_subprob', of a] by simp
lemma AE_not_suntil_coinduct [consumes 1, case_names ψ φ]:
assumes "P s"
assumes ψ: "⋀s. P s ⟹ s ∉ ψ"
assumes φ: "⋀s t. P s ⟹ s ∈ φ ⟹ t ∈ K s ⟹ P t"
shows "AE ω in T s. not (HLD φ suntil HLD ψ) (s ## ω)"
proof -
{ fix ω have "¬ (HLD φ suntil HLD ψ) (s ## ω) ⟷
(∀n. ¬ ((λR. HLD ψ or (HLD φ aand nxt R)) ^^ n) ⊥ (s ## ω))"
unfolding suntil_def
by (subst sup_continuous_lfp)
(auto simp add: sup_continuous_def) }
moreover
{ fix n from ‹P s› have "AE ω in T s. ¬ ((λR. HLD ψ or (HLD φ aand nxt R)) ^^ n) ⊥ (s ## ω)"
proof (induction n arbitrary: s)
case (Suc n) then show ?case
apply (subst AE_T_iff)
apply (rule measurable_compose[OF measurable_Stream, where M1="count_space UNIV"])
apply measurable
apply simp
apply (auto simp: bot_fun_def intro!: AE_impI dest: φ ψ)
done
qed simp }
ultimately show ?thesis
by (simp add: AE_all_countable)
qed
lemma AE_not_suntil_coinduct_strong [consumes 1, case_names ψ φ]:
assumes "P s"
assumes P_ψ: "⋀s. P s ⟹ s ∉ ψ"
assumes P_φ: "⋀s t. P s ⟹ s ∈ φ ⟹ t ∈ K s ⟹ P t ∨
(AE ω in T t. not (HLD φ suntil HLD ψ) (t ## ω))"
shows "AE ω in T s. not (HLD φ suntil HLD ψ) (s ## ω)" (is "?nuntil s")
proof -
have "P s ∨ ?nuntil s"
using ‹P s› by auto
then show ?thesis
proof (coinduction arbitrary: s rule: AE_not_suntil_coinduct)
case (φ t s) then show ?case
by (auto simp: AE_T_iff[of _ s] suntil_Stream[of _ _ s] dest: P_φ)
qed (auto simp: suntil_Stream dest: P_ψ)
qed
end
subsection ‹Reward Structure on Markov Chains›
locale MC_with_rewards = MC_syntax K for K :: "'s ⇒ 's pmf" +
fixes ι :: "'s ⇒ 's ⇒ ennreal" and ρ :: "'s ⇒ ennreal"
assumes ι_nonneg: "⋀s t. 0 ≤ ι s t" and ρ_nonneg: "⋀s. 0 ≤ ρ s"
assumes measurable_ι[measurable]: "(λ(a, b). ι a b) ∈ borel_measurable (count_space UNIV ⨂⇩M count_space UNIV)"
begin
definition reward_until :: "'s set ⇒ 's ⇒ 's stream ⇒ ennreal" where
"reward_until X = lfp (λF s ω. if s ∈ X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω)))"
lemma measurable_ρ[measurable]: "ρ ∈ borel_measurable (count_space UNIV)"
by simp
lemma measurable_reward_until[measurable (raw)]:
assumes [measurable]: "f ∈ measurable M (count_space UNIV)"
assumes [measurable]: "g ∈ measurable M S"
shows "(λx. reward_until X (f x) (g x)) ∈ borel_measurable M"
proof -
let ?F = "λF (s, ω). if s ∈ X then 0 else ρ s + ι s (shd ω) + (F (shd ω, stl ω))"
{ fix s ω
have "reward_until X s ω = lfp ?F (s, ω)"
unfolding reward_until_def lfp_pair[symmetric] .. }
note * = this
have [measurable]: "lfp ?F ∈ borel_measurable (count_space UNIV ⨂⇩M S)"
proof (rule borel_measurable_lfp)
fix f :: "('s × 's stream) ⇒ ennreal"
assume [measurable]: "f ∈ borel_measurable (count_space UNIV ⨂⇩M S)"
show "?F f ∈ borel_measurable (count_space UNIV ⨂⇩M S)"
unfolding split_beta'
apply (intro measurable_If)
apply measurable []
apply measurable []
apply (rule predE)
apply (rule measurable_compose[OF measurable_fst])
apply measurable []
done
qed (auto intro!: ι_nonneg ρ_nonneg order_continuous_intros)
show ?thesis
unfolding * by measurable
qed
lemma continuous_reward_until:
"sup_continuous (λF s ω. if s ∈ X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω)))"
by (intro ι_nonneg ρ_nonneg order_continuous_intros) (auto simp: sup_continuous_def image_comp)
lemma
shows reward_until_unfold: "reward_until X s ω =
(if s ∈ X then 0 else ρ s + ι s (shd ω) + reward_until X (shd ω) (stl ω))"
(is ?unfold)
proof -
let ?F = "λF s ω. if s ∈ X then 0 else ρ s + ι s (shd ω) + (F (shd ω) (stl ω))"
{ fix s ω have "reward_until X s ω = ?F (reward_until X) s ω"
unfolding reward_until_def
apply (subst lfp_unfold)
apply (rule continuous_reward_until[THEN sup_continuous_mono, of X])
apply rule
done }
note step = this
show ?unfold
by (subst step) (auto intro!: arg_cong2[where f="(+)"])
qed
lemma reward_until_simps[simp]:
shows "s ∈ X ⟹ reward_until X s ω = 0"
and "s ∉ X ⟹ reward_until X s ω = ρ s + ι s (shd ω) + reward_until X (shd ω) (stl ω)"
unfolding reward_until_unfold[of X s ω] by simp_all
lemma reward_until_SCons[simp]:
"reward_until X s (t ## ω) = (if s ∈ X then 0 else ρ s + ι s t + reward_until X t ω)"
by simp
lemma nn_integral_reward_until_finite:
assumes [simp]: "finite (acc `` {s})" (is "finite (?R `` {s})")
assumes ρ: "⋀t. (s, t) ∈ acc_on (-H) ⟹ ρ t < ∞"
assumes ι: "⋀t t'. (s, t) ∈ acc_on (-H) ⟹ t' ∈ K t ⟹ ι t t' < ∞"
assumes ev: "AE ω in T s. ev (HLD H) ω"
shows "(∫⇧+ ω. reward_until H s ω ∂T s) ≠ ∞"
proof cases
assume "s ∈ H" then show ?thesis
by simp
next
assume "s ∉ H"
let ?L = "acc_on (-H)"
define M where "M = Max ((λ(s, t). ρ s + ι s t) ` (SIGMA t:?L``{s}. K t))"
have "?L ⊆ ?R"
by (intro rtrancl_mono) auto
with ‹s ∉ H› have subset: "(SIGMA t:?L``{s}. K t) ⊆ (?R``{s} × ?R``{s})"
by (auto intro: rtrancl_into_rtrancl elim: rtrancl.cases)
then have [simp, intro!]: "finite ((λ(s, t). ρ s + ι s t) ` (SIGMA t:?L``{s}. K t))"
by (intro finite_imageI) (auto dest: finite_subset)
{ fix t t' assume "(s, t) ∈ ?L" "t ∉ H" "t' ∈ K t"
then have "(t, t') ∈ (SIGMA t:?L``{s}. K t)"
by (auto intro: rtrancl_into_rtrancl)
then have "ρ t + ι t t' ≤ M"
unfolding M_def by (intro Max_ge) auto }
note le_M = this
have fin_L: "finite (?L `` {s})"
by (intro finite_subset[OF _ assms(1)] Image_mono ‹?L ⊆ ?R› order_refl)
have "M < ∞"
unfolding M_def
proof (subst Max_less_iff, safe)
show "(SIGMA x:?L `` {s}. set_pmf (K x)) = {} ⟹ False"
using ‹s ∉ H› by (auto simp add: Sigma_empty_iff set_pmf_not_empty)
fix t t' assume "(s, t) ∈ ?L" "t' ∈ K t" then show "ρ t + ι t t' < ∞"
using ρ[of t] ι[of t t'] by simp
qed
from set_pmf_not_empty[of "K s"] obtain t where "t ∈ K s"
by auto
with le_M[of s t] have "0 ≤ M"
using set_pmf_not_empty[of "K s"] ‹s ∉ H› le_M[of s] ι_nonneg[of s] ρ_nonneg[of s]
by (intro order_trans[OF _ le_M]) auto
have "AE ω in T s. reward_until H s ω ≤ M * sfirst (HLD H) (s ## ω)"
using ev AE_T_enabled
proof eventually_elim
fix ω assume "ev (HLD H) ω" "enabled s ω"
moreover define t where "t = s"
ultimately have "ev (HLD H) ω" "enabled t ω" "t ∈ ?L``{s}"
by auto
then show "reward_until H t ω ≤ M * sfirst (HLD H) (t ## ω)"
proof (induction arbitrary: t rule: ev_induct_strong)
case (base ω t) then show ?case
by (auto simp: HLD_iff sfirst_Stream elim: enabled.cases intro: le_M)
next
case (step ω t) from step.IH[of "shd ω"] step.prems step.hyps show ?case
by (auto simp add: HLD_iff enabled.simps[of t] distrib_left sfirst_Stream
reward_until_simps[of t]
simp del: reward_until_simps
intro!: add_mono le_M intro: rtrancl_into_rtrancl)
qed
qed
then have "(∫⇧+ω. reward_until H s ω ∂T s) ≤ (∫⇧+ω. M * sfirst (HLD H) (s ## ω) ∂T s)"
by (rule nn_integral_mono_AE)
also have "… < ∞"
using ‹0 ≤ M› ‹M < ∞› nn_integral_sfirst_finite[OF fin_L ev]
by (simp add: nn_integral_cmult less_top[symmetric] ennreal_mult_eq_top_iff)
finally show ?thesis
by simp
qed
end
subsection ‹Bisimulation on a relation›
definition rel_set_strong :: "('a ⇒ 'b ⇒ bool) ⇒ 'a set ⇒ 'b set ⇒ bool"
where "rel_set_strong R A B ⟷ (∀x y. R x y ⟶ (x ∈ A ⟷ y ∈ B))"
lemma T_eq_rel_half[consumes 4, case_names prob sets cont]:
fixes R :: "'s ⇒ 't ⇒ bool" and f :: "'s ⇒ 't" and S :: "'s set"
assumes R_def: "⋀s t. R s t ⟷ (s ∈ S ∧ f s = t)"
assumes A[measurable]: "A ∈ sets (stream_space (count_space UNIV))"
and B[measurable]: "B ∈ sets (stream_space (count_space UNIV))"
and AB: "rel_set_strong (stream_all2 R) A B" and KL: "rel_fun R (rel_pmf R) K L" and xy: "R x y"
shows "MC_syntax.T K x A = MC_syntax.T L y B"
proof -
interpret K: MC_syntax K by unfold_locales
interpret L: MC_syntax L by unfold_locales
have "x ∈ S" using ‹R x y› by (auto simp: R_def)
define g where "g t = (SOME s. R s t)" for t
have measurable_g: "g ∈ count_space UNIV →⇩M count_space UNIV" by auto
have g: "R i j ⟹ R (g j) j" for i j
unfolding g_def by (rule someI)
have K_subset: "x ∈ S ⟹ K x ⊆ S" for x
using KL[THEN rel_funD, of x "f x", THEN rel_pmf_imp_rel_set] by (auto simp: rel_set_def R_def)
have in_S: "AE ω in K.T x. ω ∈ streams S"
using K.AE_T_enabled
proof eventually_elim
case (elim ω) with ‹x ∈ S› show ?case
apply (coinduction arbitrary: x ω)
subgoal for x ω using K_subset by (cases ω) (auto simp: K.enabled_Stream)
done
qed
have L_eq: "L y = map_pmf f (K x)" if xy: "R x y" for x y
proof -
have "rel_pmf (λx y. x = y) (map_pmf f (K x)) (L y)"
using KL[THEN rel_funD, OF xy] by (auto intro: pmf.rel_mono_strong simp: R_def pmf.rel_map)
then show ?thesis unfolding pmf.rel_eq by simp
qed
let ?D = "λx. distr (K.T x) K.S (smap f)"
have prob_space_D: "?D x ∈ space (prob_algebra K.S)" for x
by (auto simp: space_prob_algebra K.T.prob_space_distr)
have D_eq_D: "?D x = ?D x'" if "R x y" "R x' y" for x x' y
proof (rule stream_space_eq_sstart)
define A where "A = K.acc `` {x, x'}"
have x_A: "x ∈ A" "x' ∈ A" by (auto simp: A_def)
let ?Ω = "f ` A"
show "countable ?Ω"
unfolding A_def by (intro countable_image K.countable_acc) auto
show "prob_space (?D x)" "prob_space (?D x')" by (auto intro!: K.T.prob_space_distr)
show "sets (?D x) = sets L.S" "sets (?D x') = sets L.S" by auto
have AE_streams: "AE x in ?D x''. x ∈ streams ?Ω" if "x'' ∈ A" for x''
apply (simp add: space_stream_space streams_sets AE_distr_iff)
using K.AE_T_reachable[of x''] unfolding alw_HLD_iff_streams
proof eventually_elim
fix s assume "s ∈ streams (K.acc `` {x''})"
moreover have "K.acc `` {x''} ⊆ A"
using ‹x'' ∈ A› by (auto simp: A_def Image_def intro: rtrancl_trans)
ultimately show "smap f s ∈ streams (f ` A)"
by (auto intro: smap_streams)
qed
with x_A show "AE x in ?D x'. x ∈ streams ?Ω" "AE x in ?D x. x ∈ streams ?Ω"
by auto
from ‹x ∈ A› ‹x' ∈ A› that show "?D x (sstart (f ` A) xs) = ?D x' (sstart (f ` A) xs)" for xs
proof (induction xs arbitrary: x x' y)
case Nil
moreover have "?D x (streams (f ` A)) = 1" if "x ∈ A" for x
using AE_streams[of x] that
by (intro prob_space.emeasure_eq_1_AE[OF K.T.prob_space_distr]) (auto simp: streams_sets)
ultimately show ?case by simp
next
case (Cons z zs x x' y)
have "rel_pmf (R OO R¯¯) (K x) (K x')"
using KL[THEN rel_funD, OF Cons(4)] KL[THEN rel_funD, OF Cons(5)]
unfolding pmf.rel_compp pmf.rel_flip by auto
then obtain p :: "('s × 's) pmf" where p: "⋀a b. (a, b) ∈ p ⟹ (R OO R¯¯) a b" and
eq: "map_pmf fst p = K x" "map_pmf snd p = K x'"
by (auto simp: pmf.in_rel)
let ?S = "stream_space (count_space UNIV)"
have *: "(##) y -` smap f -` sstart (f ` A) (z # zs) = (if f y = z then smap f -` sstart (f ` A) zs else {})" for y z zs
by auto
have **: "?D x (sstart (f ` A) (z # zs)) = (∫⇧+ y'. (if f y' = z then ?D y' (sstart (f ` A) zs) else 0) ∂K x)" for x
apply (simp add: emeasure_distr)
apply (subst K.T_eq_bind)
apply (subst emeasure_bind[where N="?S"])
apply simp
apply (rule measurable_distr2[where M="?S"])
apply measurable
apply (intro nn_integral_cong_AE AE_pmfI)
apply (auto simp add: emeasure_distr)
apply (simp_all add: * space_stream_space)
done
have fst_A: "fst ab ∈ A" if "ab ∈ p" for ab
proof -
have "fst ab ∈ K x" using ‹ab ∈ p› set_map_pmf [of fst p] by (auto simp: eq)
with ‹x ∈ A› show "fst ab ∈ A"
by (auto simp: A_def intro: rtrancl.rtrancl_into_rtrancl)
qed
have snd_A: "snd ab ∈ A" if "ab ∈ p" for ab
proof -
have "snd ab ∈ K x'" using ‹ab ∈ p› set_map_pmf [of snd p] by (auto simp: eq)
with ‹x' ∈ A› show "snd ab ∈ A"
by (auto simp: A_def intro: rtrancl.rtrancl_into_rtrancl)
qed
show ?case
unfolding ** eq[symmetric] nn_integral_map_pmf
apply (intro nn_integral_cong_AE AE_pmfI)
subgoal for ab using p[of "fst ab" "snd ab"] by (auto simp: R_def intro!: Cons(1) fst_A snd_A)
done
qed
qed
have L_eq_D: "L.T y = ?D x"
using ‹R x y›
proof (coinduction arbitrary: x y rule: L.T_coinduct)
case (cont x y)
then have Kx_Ly: "rel_pmf R (K x) (L y)"
by (rule KL[THEN rel_funD])
then have *: "y' ∈ L y ⟹ ∃x'∈K x. R x' y'" for y'
by (auto dest!: rel_pmf_imp_rel_set simp: rel_set_def)
have **: "y' ∈ L y ⟹ R (g y') y'" for y'
using *[of y'] unfolding g_def by (auto intro: someI)
have D_SCons_eq_D_D: "distr (K.T i) K.S (λx. z ## smap f x) = distr (?D i) K.S (λx. z ## x)" for i z
by (subst distr_distr) (auto simp: comp_def)
have D_eq_D_gi: "?D i = ?D (g (f i))" if i: "i ∈ K x" for i
proof -
obtain j where "j ∈ L y" "R i j" "f i = j"
using Kx_Ly i by (force dest!: rel_pmf_imp_rel_set simp: rel_set_def R_def)
then show ?thesis
by (auto intro!: D_eq_D[OF ‹R i j›] g)
qed
have ***: "?D x = measure_pmf (L y) ⤜ (λy. distr (?D (g y)) K.S ((##) y))"
apply (subst K.T_eq_bind)
apply (subst distr_bind[of _ _ K.S])
apply (rule measurable_distr2[of _ _ "K.S"])
apply (simp_all add: Pi_iff)
apply (simp add: distr_distr comp_def L_eq[OF cont] map_pmf_rep_eq)
apply (subst bind_distr[where K=K.S])
apply measurable []
apply (rule measurable_distr2[of _ _ "K.S"])
apply measurable []
apply (rule measurable_compose[OF measurable_g])
apply measurable []
apply simp
apply (rule bind_measure_pmf_cong[where N="K.S"])
apply (auto simp: space_subprob_algebra space_stream_space intro!: K.T.subprob_space_distr)
unfolding D_SCons_eq_D_D D_eq_D_gi ..
show ?case
by (intro exI[of _ "λt. distr (K.T (g t)) (stream_space (count_space UNIV)) (smap f)"])
(auto simp add: K.T.prob_space_distr *** dest: **)
qed (auto intro: K.T.prob_space_distr)
have "stream_all2 R s t ⟷ (s ∈ streams S ∧ smap f s = t)" for s t
proof safe
show "stream_all2 R s t ⟹ s ∈ streams S"
apply (coinduction arbitrary: s t)
subgoal for s t by (cases s; cases t) (auto simp: R_def)
done
show "stream_all2 R s t ⟹ smap f s = t"
apply (coinduction arbitrary: s t)
subgoal for s t by (cases s; cases t) (auto simp: R_def)
done
qed (auto intro!: stream.rel_refl_strong simp: stream.rel_map R_def streams_iff_sset)
then have "ω ∈ streams S ⟹ ω ∈ A ⟷ smap f ω ∈ B" for ω
using AB by (auto simp: rel_set_strong_def)
with in_S have "K.T x A = K.T x (smap f -` B ∩ space (K.T x))"
by (auto intro!: emeasure_eq_AE streams_sets)
also have "… = (distr (K.T x) K.S (smap f)) B"
by (intro emeasure_distr[symmetric]) auto
also have "… = (L.T y) B" unfolding L_eq_D ..
finally show ?thesis .
qed
subsection ‹Product Construction›
locale MC_pair =
K1: MC_syntax K1 + K2: MC_syntax K2 for K1 K2
begin
definition "Kp ≡ λ(a, b). pair_pmf (K1 a) (K2 b)"
sublocale MC_syntax Kp .
definition
"szip⇩E a b ≡ λ(ω1, ω2). szip (K1.force_enabled a ω1) (K2.force_enabled b ω2)"
lemma szip_rT[measurable]: "(λ(ω1, ω2). szip ω1 ω2) ∈ measurable (K1.rT x1 ⨂⇩M K2.rT x2) S"
proof (rule measurable_stream_space2)
fix n
have "(λx. (case x of (ω1, ω2) ⇒ szip ω1 ω2) !! n) = (λω. (fst ω !! n, snd ω !! n))"
by auto
also have "… ∈ measurable (K1.rT x1 ⨂⇩M K2.rT x2) (count_space UNIV)"
apply (rule measurable_compose_countable'[OF _ measurable_compose[OF measurable_fst K1.snth_rT, of n]])
apply (rule measurable_compose_countable'[OF _ measurable_compose[OF measurable_snd K2.snth_rT, of n]])
apply (auto intro!: K1.countable_acc K2.countable_acc)
done
finally show "(λx. (case x of (ω1, ω2) ⇒ szip ω1 ω2) !! n) ∈ measurable (K1.rT x1 ⨂⇩M K2.rT x2) (count_space UNIV)"
.
qed
lemma measurable_szipE[measurable]: "szip⇩E a b ∈ measurable (K1.S ⨂⇩M K2.S) S"
unfolding szip⇩E_def by measurable
lemma T_eq_prod: "T = (λ(x1, x2). do { ω1 ← K1.T x1 ; ω2 ← K2.T x2 ; return S (szip⇩E x1 x2 (ω1, ω2)) })"
(is "_ = ?B")
proof (rule T_bisim)
have T1x: "⋀x. subprob_space (K1.T x)"
by (rule prob_space_imp_subprob_space) unfold_locales
interpret T12: pair_prob_space "K1.T x" "K2.T y" for x y
by unfold_locales
interpret T1K2: pair_prob_space "K1.T x" "K2 y" for x y
by unfold_locales
let ?P = "λx1 x2. K1.T x1 ⨂⇩M K2.T x2"
fix x show "prob_space (?B x)"
by (auto simp: space_stream_space split: prod.splits
intro!: prob_space.prob_space_bind prob_space_return
measurable_bind[where N=S] measurable_compose[OF _ return_measurable] AE_I2)
unfold_locales
show "sets (?B x) = sets S"
by (simp split: prod.splits add: measurable_bind[where N=S] sets_bind[where N=S] space_stream_space)
obtain a b where x_eq: "x = (a, b)"
by (cases x) auto
show "?B x = (measure_pmf (Kp x) ⤜ (λs. distr (?B s) S ((##) s)))"
unfolding x_eq
apply (subst K1.T_eq_bind')
apply (subst K2.T_eq_bind')
apply (auto
simp add: space_stream_space bind_assoc[where R=S and N=S] bind_return_distr[symmetric]
Kp_def T1K2.bind_rotate[where N=S] split_beta' set_pair_pmf space_subprob_algebra
bind_pair_pmf[of "case_prod M" for M, unfolded split, symmetric, where N=S] szip⇩E_def
stream_eq_Stream_iff bind_return[where N=S] space_bind[where N=S]
simp del: measurable_pmf_measure1
intro!: bind_measure_pmf_cong[where N=S] subprob_space_bind[where N=S] subprob_space_measure_pmf
T1x bind_cong[where M="MC_syntax.T K x" for K x] arg_cong2[where f=return])
done
qed
lemma nn_integral_pT:
fixes f assumes [measurable]: "f ∈ borel_measurable S"
shows "(∫⇧+ω. f ω ∂T (x, y)) = (∫⇧+ω1. ∫⇧+ω2. f (szip⇩E x y (ω1, ω2)) ∂K2.T y ∂K1.T x)"
by (simp add: nn_integral_bind[where B=S] nn_integral_return in_S T_eq_prod)
lemma prod_eq_prob_T:
assumes [measurable]: "Measurable.pred K1.S P1" "Measurable.pred K2.S P2"
shows "𝒫(ω in K1.T x1. P1 ω) * 𝒫(ω in K2.T x2. P2 ω) =
𝒫(ω in T (x1, x2). P1 (smap fst ω) ∧ P2 (smap snd ω))"
proof -
have "𝒫(ω in T (x1, x2). P1 (smap fst ω) ∧ P2 (smap snd ω)) =
(∫ x. ∫ xa. indicator {ω ∈ space S. P1 (smap fst ω) ∧ P2 (smap snd ω)} (szip⇩E x1 x2 (x, xa)) ∂MC_syntax.T K2 x2 ∂MC_syntax.T K1 x1)"
by (subst T_eq_prod)
(simp add: K1.T.measure_bind[where N=S] K2.T.measure_bind[where N=S] measure_return)
also have "... = (∫ω1. ∫ω2. indicator {ω∈space K1.S. P1 ω} ω1 * indicator {ω∈space K2.S. P2 ω} ω2 ∂K2.T x2 ∂K1.T x1)"
apply (intro integral_cong_AE)
apply measurable
using K1.AE_T_enabled
apply eventually_elim
apply (intro integral_cong_AE)
apply measurable
using K2.AE_T_enabled
apply eventually_elim
apply (auto simp: space_stream_space szip⇩E_def K1.force_enabled K2.force_enabled
smap_szip_snd[where g="λx. x"] smap_szip_fst[where f="λx. x"]
split: split_indicator)
done
also have "… = 𝒫(ω in K1.T x1. P1 ω) * 𝒫(ω in K2.T x2. P2 ω)"
by simp
finally show ?thesis ..
qed
end
end
Theory Trace_Space_Equals_Markov_Processes
subsection ‹Trace Space equal to Markov Chains›
theory Trace_Space_Equals_Markov_Processes
imports Discrete_Time_Markov_Chain
begin
text ‹
We can construct for each time-homogeneous discrete-time Markov chain a corresponding
probability space using @{theory Markov_Models.Discrete_Time_Markov_Chain}. The constructed probability space
has the same probabilities.
›
locale Time_Homogeneous_Discrete_Markov_Process = M?: prob_space +
fixes S :: "'s set" and X :: "nat ⇒ 'a ⇒ 's"
assumes X [measurable]: "⋀t. X t ∈ measurable M (count_space UNIV)"
assumes S: "countable S" "⋀n. AE x in M. X n x ∈ S"
assumes MC: "⋀n s s'.
𝒫(ω in M. ∀t≤n. X t ω = s t ) ≠ 0 ⟹
𝒫(ω in M. X (Suc n) ω = s' ¦ ∀t≤n. X t ω = s t ) =
𝒫(ω in M. X (Suc n) ω = s' ¦ X n ω = s n )"
assumes TH: "⋀n m s t.
𝒫(ω in M. X n ω = t) ≠ 0 ⟹ 𝒫(ω in M. X m ω = t) ≠ 0 ⟹
𝒫(ω in M. X (Suc n) ω = s ¦ X n ω = t) = 𝒫(ω in M. X (Suc m) ω = s ¦ X m ω = t)"
begin
context
begin
interpretation pmf_as_measure .
lift_definition I :: "'s pmf" is "distr M (count_space UNIV) (X 0)"
proof -
let ?X = "distr M (count_space UNIV) (X 0)"
interpret X: prob_space ?X
by (auto simp: prob_space_distr)
have "AE x in ?X. measure ?X {x} ≠ 0"
using S by (subst X.AE_support_countable) (auto simp: AE_distr_iff intro!: exI[of _ S])
then show "prob_space ?X ∧ sets ?X = UNIV ∧ (AE x in ?X. measure ?X {x} ≠ 0)"
by (simp add: prob_space_distr AE_support_countable)
qed
lemma I_in_S:
assumes "pmf I s ≠ 0" shows "s ∈ S"
proof -
from ‹pmf I s ≠ 0› have "0 ≠ 𝒫(x in M. X 0 x = s)"
by transfer (auto simp: measure_distr vimage_def Int_def conj_commute)
also have "𝒫(x in M. X 0 x = s) = 𝒫(x in M. X 0 x = s ∧ s ∈ S)"
using S(2)[of 0] by (intro M.finite_measure_eq_AE) auto
finally show ?thesis
by (cases "s ∈ S") auto
qed
lift_definition K :: "'s ⇒ 's pmf" is
"λs. with (λn. 𝒫(ω in M. X n ω = s) ≠ 0)
(λn. distr (uniform_measure M {ω∈space M. X n ω = s}) (count_space UNIV) (X (Suc n)))
(uniform_measure (count_space UNIV) {s})"
proof (rule withI)
fix s n assume *: "𝒫(ω in M. X n ω = s) ≠ 0"
let ?D = "distr (uniform_measure M {ω∈space M. X n ω = s}) (count_space UNIV) (X (Suc n))"
have D: "prob_space ?D"
by (intro prob_space.prob_space_distr prob_space_uniform_measure)
(auto simp: M.emeasure_eq_measure *)
then interpret D: prob_space ?D .
have sets_D: "sets ?D = UNIV"
by simp
moreover have "AE x in ?D. measure ?D {x} ≠ 0"
unfolding D.AE_support_countable[OF sets_D]
proof (intro exI[of _ S] conjI)
show "countable S" by (rule S)
show "AE x in ?D. x ∈ S"
using * S(2)[of "Suc n"] by (auto simp add: AE_distr_iff AE_uniform_measure M.emeasure_eq_measure)
qed
ultimately show "prob_space ?D ∧ sets ?D = UNIV ∧ (AE x in ?D. measure ?D {x} ≠ 0)"
using D by blast
qed (auto intro!: prob_space_uniform_measure AE_uniform_measureI)
lemma pmf_K:
assumes n: "0 < 𝒫(ω in M. X n ω = s)"
shows "pmf (K s) t = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
proof (transfer fixing: n s t)
let ?P = "λn. 𝒫(ω in M. X n ω = s) ≠ 0"
let ?D = "λn. distr (uniform_measure M {ω∈space M. X n ω = s}) (count_space UNIV) (X (Suc n))"
let ?U = "uniform_measure (count_space UNIV) {s}"
show "measure (with ?P ?D ?U) {t} = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
proof (rule withI)
fix n' assume "?P n'"
moreover have "X (Suc n') -` {t} ∩ space M = {x∈space M. X (Suc n') x = t}"
by auto
ultimately show "measure (?D n') {t} = 𝒫(ω in M. X (Suc n) ω = t ¦ X n ω = s)"
using n M.measure_uniform_measure_eq_cond_prob[of "λx. X (Suc n') x = t" "λx. X n' x = s"]
by (auto simp: measure_distr M.emeasure_eq_measure simp del: measure_uniform_measure intro!: TH)
qed (insert n, simp)
qed
lemma pmf_K2:
"(⋀n. 𝒫(ω in M. X n ω = s) = 0) ⟹ pmf (K s) t = indicator {t} s"
apply (transfer fixing: s t)
apply (rule withI)
apply (auto split: split_indicator)
done
end
sublocale K: MC_syntax K .
lemma bind_I_K_eq_M: "K.T' I = distr M K.S (λω. to_stream (λn. X n ω))" (is "_ = ?D")
proof (rule stream_space_eq_sstart)
note streams_sets[measurable]
note measurable_abs_UNIV[measurable (raw)]
note sstart_sets[measurable]
{ fix s assume "s ∈ S"
from K.AE_T_enabled[of s] have "AE ω in K.T s. ω ∈ streams S"
proof eventually_elim
fix ω assume "K.enabled s ω" from this ‹s∈S› show "ω ∈ streams S"
proof (coinduction arbitrary: s ω)
case streams
then have 1: "pmf (K s) (shd ω) ≠ 0"
by (simp add: K.enabled.simps[of s] set_pmf_iff)
have "shd ω ∈ S"
proof cases
assume "∃n. 0 < 𝒫(ω in M. X n ω = s)"
then obtain n where "0 < 𝒫(ω in M. X n ω = s)" by auto
with 1 have 2: "𝒫(ω' in M. X (Suc n) ω' = shd ω ∧ X n ω' = s) ≠ 0"
by (simp add: pmf_K cond_prob_def)
show "shd ω ∈ S"
proof (rule ccontr)
assume "shd ω ∉ S"
with S(2)[of "Suc n"] have "𝒫(ω' in M. X (Suc n) ω' = shd ω ∧ X n ω' = s) = 0"
by (intro M.prob_eq_0_AE) auto
with 2 show False by contradiction
qed
next
assume "¬ (∃n. 0 < 𝒫(ω in M. X n ω = s))"
then have "pmf (K s) (shd ω) = indicator {shd ω} s"
by (intro pmf_K2) (auto simp: not_less measure_le_0_iff)
with 1 ‹s∈S› show ?thesis
by (auto split: split_indicator_asm)
qed
with streams show ?case
by (cases ω) (auto simp: K.enabled.simps[of s])
qed
qed }
note AE_streams = this
show "prob_space (K.T' I)"
by (rule K.prob_space_T')
show "prob_space ?D"
by (rule M.prob_space_distr) simp
show "AE x in K.T' I. x ∈ streams S"
by (auto simp add: K.AE_T' set_pmf_iff I_in_S AE_distr_iff streams_Stream intro!: AE_streams)
show "AE x in ?D. x ∈ streams S"
by (simp add: AE_distr_iff to_stream_in_streams AE_all_countable S)
show "sets (K.T' I) = sets (stream_space (count_space UNIV))"
by (simp add: K.sets_T')
show "sets ?D = sets (stream_space (count_space UNIV))"
by simp
fix xs' assume "xs' ≠ []" "xs' ∈ lists S"
then obtain s xs where xs': "xs' = s # xs" and s: "s ∈ S" and xs: "xs ∈ lists S"
by (auto simp: neq_Nil_conv del: in_listsD)
have "emeasure (K.T' I) (sstart S xs') = (∫⇧+s. emeasure (K.T s) {ω∈space K.S. s ## ω ∈ sstart S xs'} ∂I)"
by (rule K.emeasure_T') measurable
also have "… = (∫⇧+s'. emeasure (K.T s) (sstart S xs) * indicator {s} s' ∂I)"
by (intro arg_cong2[where f=emeasure] nn_integral_cong)
(auto split: split_indicator simp: emeasure_distr vimage_def space_stream_space neq_Nil_conv xs')
also have "… = pmf I s * emeasure (K.T s) (sstart S xs)"
by (auto simp add: max_def emeasure_pmf_single intro: mult_ac)
also have "emeasure (K.T s) (sstart S xs) = ennreal (∏i<length xs. pmf (K ((s#xs)!i)) (xs!i))"
using xs s
proof (induction arbitrary: s)
case Nil then show ?case
by (simp add: K.T.emeasure_eq_1_AE AE_streams)
next
case (Cons t xs)
have "emeasure (K.T s) (sstart S (t # xs)) =
emeasure (K.T s) {x∈space (K.T s). shd x = t ∧ stl x ∈ sstart S xs}"
by (intro arg_cong2[where f=emeasure]) (auto simp: space_stream_space)
also have "… = (∫⇧+t'. emeasure (K.T t') {x∈space K.S. t' = t ∧ x ∈ sstart S xs} ∂K s)"
by (subst K.emeasure_Collect_T) auto
also have "… = (∫⇧+t'. emeasure (K.T t) (sstart S xs) * indicator {t} t' ∂K s)"
by (intro nn_integral_cong) (auto split: split_indicator simp: space_stream_space)
also have "… = emeasure (K.T t) (sstart S xs) * pmf (K s) t"
by (simp add: emeasure_pmf_single max_def)
finally show ?case
by (simp add: lessThan_Suc_eq_insert_0 zero_notin_Suc_image prod.reindex Cons
prod_nonneg ennreal_mult[symmetric])
qed
also have "pmf I s * ennreal (∏i<length xs. pmf (K ((s#xs)!i)) (xs!i)) =
𝒫(x in M. ∀i≤length xs. X i x = (s # xs) ! i)"
using xs s
proof (induction xs rule: rev_induct)
case Nil
have "pmf I s = prob {x ∈ space M. X 0 x = s}"
by transfer (simp add: vimage_def Int_def measure_distr conj_commute)
then show ?case
by simp
next
case (snoc t xs)
let ?l = "length xs" and ?lt = "length (xs @ [t])" and ?xs' = "s # xs @ [t]"
have "ennreal (pmf I s) * (∏i<?lt. pmf (K ((?xs') ! i)) ((xs @ [t]) ! i)) =
(ennreal (pmf I s) * (∏i<?l. pmf (K ((s # xs) ! i)) (xs ! i))) * pmf (K ((s # xs) ! ?l)) t"
by (simp add: lessThan_Suc mult_ac nth_append append_Cons[symmetric] prod_nonneg ennreal_mult[symmetric]
del: append_Cons)
also have "… = 𝒫(x in M. ∀i≤?l. X i x = (s # xs) ! i) * pmf (K ((s # xs) ! ?l)) t"
using snoc by (simp add: ennreal_mult[symmetric])
also have "… = 𝒫(x in M. ∀i≤?lt. X i x = (?xs') ! i)"
proof cases
assume "𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i) = 0"
moreover have "𝒫(x in M. ∀i≤?lt. X i x = (?xs') ! i) ≤ 𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i)"
by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
moreover have "𝒫(x in M. ∀i≤?l. X i x = (s # xs) ! i) ≤ 𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i)"
by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
ultimately show ?thesis
by (simp add: measure_le_0_iff)
next
assume "𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i) ≠ 0"
then have *: "0 < 𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i)"
unfolding less_le by simp
moreover have "𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i) ≤ 𝒫(ω in M. X ?l ω = (s # xs) ! ?l)"
by (intro M.finite_measure_mono) (auto simp: nth_append nth_Cons split: nat.split)
ultimately have "𝒫(ω in M. X ?l ω = (s # xs) ! ?l) ≠ 0"
by auto
then have "pmf (K ((s # xs) ! ?l)) t = 𝒫(ω in M. X ?lt ω = ?xs' ! ?lt ¦ X ?l ω = (s # xs) ! ?l)"
by (subst pmf_K) (auto simp: less_le)
also have "… = 𝒫(ω in M. X ?lt ω = ?xs' ! ?lt ¦ ∀i≤?l. X i ω = (s # xs) ! i)"
using * MC[of ?l "λi. (s # xs) ! i" "?xs' ! ?lt"] by simp
also have "… = 𝒫(ω in M. ∀i≤?lt. X i ω = ?xs' ! i) / 𝒫(ω in M. ∀i≤?l. X i ω = (s # xs) ! i)"
unfolding cond_prob_def
by (intro arg_cong2[where f="(/)"] arg_cong2[where f=measure]) (auto simp: nth_Cons nth_append split: nat.splits)
finally show ?thesis
using * by simp
qed
finally show ?case .
qed
also have "… = emeasure ?D (sstart S xs')"
proof -
have "AE x in M. ∀i. X i x ∈ S"
using S(2) by (simp add: AE_all_countable)
then have "AE x in M. (∀i≤length xs. X i x = (s # xs) ! i) = (to_stream (λn. X n x) ∈ sstart S xs')"
proof eventually_elim
fix x assume "∀i. X i x ∈ S"
then have "to_stream (λn. X n x) ∈ streams S"
by (auto simp: streams_iff_snth to_stream_def)
then show "(∀i≤length xs. X i x = (s # xs) ! i) = (to_stream (λn. X n x) ∈ sstart S xs')"
by (simp add: sstart_eq xs' to_stream_def less_Suc_eq_le del: sstart.simps(1) in_sstart)
qed
then show ?thesis
by (auto simp: emeasure_distr M.emeasure_eq_measure intro!: M.finite_measure_eq_AE)
qed
finally show "emeasure (K.T' I) (sstart S xs') = emeasure ?D (sstart S xs')" .
qed (rule S)
end
lemma (in MC_syntax) is_THDTMC:
fixes I :: "'s pmf"
defines "U ≡ (SIGMA s:UNIV. K s)⇧* `` I"
shows "Time_Homogeneous_Discrete_Markov_Process (T' I) U (λn ω. ω !! n)"
proof -
have [measurable]: "U ∈ sets (count_space UNIV)"
by auto
interpret prob_space "T' I"
by (rule prob_space_T')
{ fix s t I
have "⋀t s. 𝒫(ω in T s. s = t) = indicator {t} s"
using T.prob_space by (auto split: split_indicator)
moreover then have "⋀t t' s. 𝒫(ω in T s. shd ω = t' ∧ s = t) = pmf (K t) t' * indicator {t} s"
by (subst prob_T) (auto split: split_indicator simp: pmf.rep_eq)
ultimately have "𝒫(ω in T' I. shd (stl ω) = t ∧ shd ω = s) = 𝒫(ω in T' I. shd ω = s) * pmf (K s) t"
by (simp add: prob_T' pmf.rep_eq) }
note start_eq = this
{ fix n s t assume "𝒫(ω in T' I. ω !! n = s) ≠ 0"
moreover have "𝒫(ω in T' I. ω !! (Suc n) = t ∧ ω !! n = s) = 𝒫(ω in T' I. ω !! n = s) * pmf (K s) t"
proof (induction n arbitrary: I)
case (Suc n) then show ?case
by (subst (1 2) prob_T') (simp_all del: space_T add: T_eq_T')
qed (simp add: start_eq)
ultimately have "𝒫(ω in T' I. stl ω !! n = t ¦ ω !! n = s) = pmf (K s) t"
by (simp add: cond_prob_def field_simps) }
note TH = this
{ fix n ω' t assume "𝒫(ω in T' I. ∀i≤n. ω !! i = ω' i) ≠ 0"
moreover have "𝒫(ω in T' I. ω !! (Suc n) = t ∧ (∀i≤n. ω !! i = ω' i)) =
𝒫(ω in T' I. ∀i≤n. ω !! i = ω' i) * pmf (K (ω' n)) t"
proof (induction n arbitrary: I ω')
case (Suc n)
have *[simp]: "⋀s P. measure (T' (K s)) {x. s = ω' 0 ∧ P x} =
measure (T' (K (ω' 0))) {x. P x} * indicator {ω' 0} s"
by (auto split: split_indicator)
from Suc[of _ "λi. ω' (Suc i)"] show ?case
by (subst (1 2) prob_T')
(simp_all add: T_eq_T' all_Suc_split[where P="λi. i ≤ Suc n ⟶ Q i" for n Q] conj_commute conj_left_commute sets_eq_imp_space_eq[OF sets_T'])
qed (simp add: start_eq)
ultimately have "𝒫(ω in T' I. stl ω !! n = t ¦ ∀i≤n. ω !! i = ω' i) = pmf (K (ω' n)) t"
by (simp add: cond_prob_def field_simps) }
note MC = this
{ fix n ω' assume "𝒫(ω in T' I. ∀t≤n. ω !! t = ω' t) ≠ 0"
moreover have "𝒫(ω in T' I. ∀t≤n. ω !! t = ω' t) ≤ 𝒫(ω in T' I. ω !! n = ω' n)"
by (auto intro!: finite_measure_mono_AE simp: sets_T' sets_eq_imp_space_eq[OF sets_T'])
ultimately have "𝒫(ω in T' I. ω !! n = ω' n) ≠ 0"
by (auto simp: neq_iff not_less measure_le_0_iff) }
note MC' = this
show ?thesis
proof
show "countable U"
unfolding U_def by (rule countable_reachable countable_Image countable_set_pmf)+
show "⋀t. (λω. ω !! t) ∈ measurable (T' I) (count_space UNIV)"
by (subst measurable_cong_sets[OF sets_T' refl]) simp
next
fix n
have "∀x∈I. AE y in T x. (x ## y) !! n ∈ U"
unfolding U_def
proof (induction n arbitrary: I)
case 0 then show ?case
by auto
next
case (Suc n)
{ fix x assume "x ∈ I"
have "AE y in T x. y !! n ∈ (SIGMA x:UNIV. K x)⇧* `` K x"
apply (subst AE_T_iff)
apply (rule measurable_compose[OF measurable_snth], simp)
apply (rule Suc)
done
moreover have "(SIGMA x:UNIV. K x)⇧* `` K x ⊆ (SIGMA x:UNIV. K x)⇧* `` I"
using ‹x ∈ I› by (auto intro: converse_rtrancl_into_rtrancl)
ultimately have "AE y in T x. y !! n ∈ (SIGMA x:UNIV. K x)⇧* `` I"
by (auto simp: subset_eq) }
then show ?case
by simp
qed
then show "AE x in T' I. x !! n ∈ U"
by (simp add: AE_T')
qed (simp_all add: TH MC MC')
qed
end
Theory Classifying_Markov_Chain_States
section ‹Classifying Markov Chain States›
theory Classifying_Markov_Chain_States
imports
"HOL-Computational_Algebra.Group_Closure"
Discrete_Time_Markov_Chain
begin
lemma eventually_mult_Gcd:
fixes S :: "nat set"
assumes S: "⋀s t. s ∈ S ⟹ t ∈ S ⟹ s + t ∈ S"
assumes s: "s ∈ S" "s > 0"
shows "eventually (λm. m * Gcd S ∈ S) sequentially"
proof -
define T where "T = insert 0 (int ` S)"
with s S have "int s ∈ T" "0 ∈ T" and T: "r ∈ T ⟹ t ∈ T ⟹ r + t ∈ T" for r t
by (auto simp del: of_nat_add simp add: of_nat_add [symmetric])
have "Gcd T ∈ group_closure T"
by (rule Gcd_in_group_closure)
also have "group_closure T = {s - t | s t. s ∈ T ∧ t ∈ T}"
proof (auto intro: group_closure.base group_closure.diff)
fix x assume "x ∈ group_closure T"
then show "∃s t. x = s - t ∧ s ∈ T ∧ t ∈ T"
proof induction
case (base x) with ‹0 ∈ T› show ?case
apply (rule_tac x=x in exI)
apply (rule_tac x=0 in exI)
apply auto
done
next
case (diff x y)
then obtain a b c d where
"a ∈ T" "b ∈ T" "x = a - b"
"c ∈ T" "d ∈ T" "y = c - d"
by auto
then show ?case
apply (rule_tac x="a + d" in exI)
apply (rule_tac x="b + c" in exI)
apply (auto intro: T)
done
qed
qed
finally obtain s' t' :: int
where "s' ∈ T" "t' ∈ T" "Gcd T = s' - t'"
by blast
moreover define s and t where "s = nat s'" and "t = nat t'"
moreover have "int (Gcd S) = - int t ⟷ S ⊆ {0} ∧ t = 0"
by auto (metis Gcd_dvd_nat dvd_0_right dvd_antisym nat_int nat_zminus_int)
ultimately have
st: "s = 0 ∨ s ∈ S" "t = 0 ∨ t ∈ S" and Gcd_S: "Gcd S = s - t"
using T_def by safe simp_all
with s
have "t < s"
by (rule_tac ccontr) auto
{ fix s n have "0 < n ⟹ s ∈ S ⟹ n * s ∈ S"
proof (induct n)
case (Suc n) then show ?case
by (cases n) (auto intro: S)
qed simp }
note cmult_S = this
show ?thesis
unfolding eventually_sequentially
proof cases
assume "s = 0 ∨ t = 0"
with st Gcd_S s have *: "Gcd S ∈ S"
by (auto simp: int_eq_iff)
then show "∃N. ∀n≥N. n * Gcd S ∈ S" by (auto intro!: exI[of _ 1] cmult_S)
next
assume "¬ (s = 0 ∨ t = 0)"
with st have "s ∈ S" "t ∈ S" "t ≠ 0" by auto
then have "Gcd S dvd t" by auto
then obtain a where a: "t = Gcd S * a" ..
with ‹t ≠ 0› have "0 < a" by auto
show "∃N. ∀n≥N. n * Gcd S ∈ S"
proof (safe intro!: exI[of _ "a * a"])
fix n
define m where "m = (n - a * a) div a"
define r where "r = (n - a * a) mod a"
with ‹0 < a› have "r < a" by simp
moreover define am where "am = a + m"
ultimately have "r < am" by simp
assume "a * a ≤ n" then have n: "n = a * a + (m * a + r)"
unfolding m_def r_def by simp
have "n * Gcd S = am * t + r * Gcd S"
unfolding n a by (simp add: field_simps am_def)
also have "… = r * s + (am - r) * t"
unfolding ‹Gcd S = s - t›
using ‹t < s› ‹r < am› by (simp add: field_simps diff_mult_distrib2)
also have "… ∈ S"
using ‹s ∈ S› ‹t ∈ S› ‹r < am›
by (cases "r = 0") (auto intro!: cmult_S S)
finally show "n * Gcd S ∈ S" .
qed
qed
qed
context MC_syntax
begin
subsection ‹Expected number of visits›
definition "G s t = (∫⇧+ω. scount (HLD {t}) (s ## ω) ∂T s)"
lemma G_eq: "G s t = (∫⇧+ω. emeasure (count_space UNIV) {i. (s ## ω) !! i = t} ∂T s)"
by (simp add: G_def scount_eq_emeasure HLD_iff)
definition "p s t n = 𝒫(ω in T s. (s ## ω) !! n = t)"
definition "gf_G s t z = (∑n. p s t n *⇩R z ^ n)"
definition "convergence_G s t z ⟷ summable (λn. p s t n * norm z ^ n)"
lemma p_nonneg[simp]: "0 ≤ p x y n"
by (simp add: p_def)
lemma p_le_1: "p x y n ≤ 1"
by (simp add: p_def)
lemma p_x_x_0[simp]: "p x x 0 = 1"
by (simp add: p_def T.prob_space del: space_T)
lemma p_0: "p x y 0 = (if x = y then 1 else 0)"
by (simp add: p_def T.prob_space del: space_T)
lemma p_in_reachable: assumes "(x, y) ∉ (SIGMA x:UNIV. K x)⇧*" shows "p x y n = 0"
unfolding p_def
proof (rule T.prob_eq_0_AE)
from AE_T_reachable show "AE ω in T x. (x ## ω) !! n ≠ y"
proof eventually_elim
fix ω assume "alw (HLD ((SIGMA ω:UNIV. K ω)⇧* `` {x})) ω"
then have "alw (HLD (- {y})) ω"
using assms by (auto intro: alw_mono simp: HLD_iff)
then show "(x ## ω) !! n ≠ y"
using assms by (cases n) (auto simp: alw_HLD_iff_streams streams_iff_snth)
qed
qed
lemma p_Suc: "ennreal (p x y (Suc n)) = (∫⇧+ w. p w y n ∂K x)"
unfolding p_def T.emeasure_eq_measure[symmetric] by (subst emeasure_Collect_T) simp_all
lemma p_Suc':
"p x y (Suc n) = (∫x'. p x' y n ∂K x)"
using p_Suc[of x y n]
by (subst (asm) nn_integral_eq_integral)
(auto simp: p_le_1 intro!: measure_pmf.integrable_const_bound[where B=1])
lemma p_add: "p x y (n + m) = (∫⇧+ w. p x w n * p w y m ∂count_space UNIV)"
proof (induction n arbitrary: x)
case 0
have [simp]: "⋀w. (if x = w then 1 else 0) * p w y m = ennreal (p x y m) * indicator {x} w"
by auto
show ?case
by (simp add: p_0 one_ennreal_def[symmetric] max_def)
next
case (Suc n)
define X where "X = (SIGMA x:UNIV. K x)⇧* `` K x"
then have X: "countable X"
by (blast intro: countable_Image countable_reachable countable_set_pmf)
then interpret X: sigma_finite_measure "count_space X"
by (rule sigma_finite_measure_count_space_countable)
interpret XK: pair_sigma_finite "K x" "count_space X"
by unfold_locales
have "ennreal (p x y (Suc n + m)) = (∫⇧+t. (∫⇧+w. p t w n * p w y m ∂count_space UNIV) ∂K x)"
by (simp add: p_Suc Suc)
also have "… = (∫⇧+t. (∫⇧+w. ennreal (p t w n * p w y m) * indicator X w ∂count_space UNIV) ∂K x)"
by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def split: split_indicator)
also have "… = (∫⇧+t. (∫⇧+w. p t w n * p w y m ∂count_space X) ∂K x)"
by (subst nn_integral_restrict_space[symmetric]) (simp_all add: restrict_count_space)
also have "… = (∫⇧+w. (∫⇧+t. p t w n * p w y m ∂K x) ∂count_space X)"
apply (rule XK.Fubini'[symmetric])
unfolding measurable_split_conv
apply (rule measurable_compose_countable'[OF _ measurable_snd X])
apply (rule measurable_compose[OF measurable_fst])
apply simp
done
also have "… = (∫⇧+w. (∫⇧+t. ennreal (p t w n * p w y m) * indicator X w ∂K x) ∂count_space UNIV)"
by (simp add: nn_integral_restrict_space[symmetric] restrict_count_space nn_integral_multc)
also have "… = (∫⇧+w. (∫⇧+t. ennreal (p t w n * p w y m) ∂K x) ∂count_space UNIV)"
by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def split: split_indicator)
also have "… = (∫⇧+w. (∫⇧+t. p t w n ∂K x) * p w y m ∂count_space UNIV)"
by (simp add: nn_integral_multc[symmetric] ennreal_mult)
finally show ?case
by (simp add: ennreal_mult p_Suc)
qed
lemma prob_reachable_le:
assumes [simp]: "m ≤ n"
shows "p x y m * p y w (n - m) ≤ p x w n"
proof -
have "p x y m * p y w (n - m) = (∫⇧+y'. ennreal (p x y m * p y w (n - m)) * indicator {y} y' ∂count_space UNIV)"
by simp
also have "… ≤ p x w (m + (n - m))"
by (subst p_add)
(auto intro!: nn_integral_mono split: split_indicator simp del: nn_integral_indicator_singleton)
finally show ?thesis
by simp
qed
lemma G_eq_suminf: "G x y = (∑i. ennreal (p x y i))"
proof -
have *: "⋀i ω. indicator {ω ∈ space S. (x ## ω) !! i = y} ω = indicator {i. (x ## ω) !! i = y} i"
by (auto simp: space_stream_space split: split_indicator)
have "G x y = (∫⇧+ ω. (∑i. indicator {ω∈space (T x). (x ## ω) !! i = y} ω) ∂T x)"
unfolding G_eq by (simp add: nn_integral_count_space_nat[symmetric] *)
also have "… = (∑i. ennreal (p x y i))"
by (simp add: T.emeasure_eq_measure[symmetric] p_def nn_integral_suminf)
finally show ?thesis .
qed
lemma G_eq_real_suminf:
"convergence_G x y (1::real) ⟹ G x y = ennreal (∑i. p x y i)"
unfolding G_eq_suminf
by (intro suminf_ennreal ennreal_suminf_neq_top p_nonneg)
(auto simp: convergence_G_def p_def)
lemma convergence_norm_G:
"convergence_G x y z ⟹ summable (λn. p x y n * norm z ^ n)"
unfolding convergence_G_def .
lemma convergence_G:
"convergence_G x y (z::'a::{banach, real_normed_div_algebra}) ⟹ summable (λn. p x y n *⇩R z ^ n)"
unfolding convergence_G_def
by (rule summable_norm_cancel) (simp add: abs_mult norm_power)
lemma convergence_G_less_1:
fixes z :: "_ :: {banach, real_normed_field}"
assumes z: "norm z < 1" shows "convergence_G x y z"
unfolding convergence_G_def
proof (rule summable_comparison_test)
have "⋀n. p x y n * norm (z ^ n) ≤ 1 * norm (z ^ n)"
by (intro mult_right_mono p_le_1) simp_all
then show "∃N. ∀n≥N. norm (p x y n * norm z ^ n) ≤ norm z ^ n"
by (simp add: norm_power)
qed (simp add: z summable_geometric)
lemma lim_gf_G: "((λz. ennreal (gf_G x y z)) ⤏ G x y) (at_left (1::real))"
unfolding gf_G_def G_eq_suminf real_scaleR_def
by (intro power_series_tendsto_at_left p_nonneg p_le_1 summable_power_series)
subsection ‹Reachability probability›
definition "u x y n = 𝒫(ω in T x. ev_at (HLD {y}) n ω)"
definition "U s t = 𝒫(ω in T s. ev (HLD {t}) ω)"
definition "gf_U x y z = (∑n. u x y n *⇩R z ^ Suc n)"
definition "f x y n = 𝒫(ω in T x. ev_at (HLD {y}) n (x ## ω))"
definition "F s t = 𝒫(ω in T s. ev (HLD {t}) (s ## ω))"
definition "gf_F x y z = (∑n. f x y n * z ^ n)"
lemma f_Suc: "x ≠ y ⟹ f x y (Suc n) = u x y n"
by (simp add: u_def f_def)
lemma f_Suc_eq: "f x x (Suc n) = 0"
by (simp add: f_def)
lemma f_0: "f x y 0 = (if x = y then 1 else 0)"
using T.prob_space by (simp add: f_def)
lemma shows u_nonneg: "0 ≤ u x y n" and u_le_1: "u x y n ≤ 1"
by (simp_all add: u_def)
lemma shows f_nonneg: "0 ≤ f x y n" and f_le_1: "f x y n ≤ 1"
by (simp_all add: f_def)
lemma U_nonneg[simp]: "0 ≤ U x y"
by (simp add: U_def)
lemma U_le_1: "U s t ≤ 1"
by (auto simp add: U_def intro!: antisym)
lemma U_cases: "U s s = 1 ∨ U s s < 1"
by (auto simp add: U_def intro!: antisym)
lemma u_sums_U: "u x y sums U x y"
unfolding u_def[abs_def] U_def ev_iff_ev_at by (intro T.prob_sums) (auto intro: ev_at_unique)
lemma gf_U_eq_U: "gf_U x y 1 = U x y"
using u_sums_U[THEN sums_unique] by (simp add: gf_U_def U_def)
lemma f_sums_F: "f x y sums F x y"
unfolding f_def[abs_def] F_def ev_iff_ev_at
by (intro T.prob_sums) (auto intro: ev_at_unique)
lemma F_nonneg[simp]: "0 ≤ F x y"
by (auto simp: F_def)
lemma F_le_1: "F x y ≤ 1"
by (simp add: F_def)
lemma gf_F_eq_F: "gf_F x y 1 = F x y"
using f_sums_F[THEN sums_unique] by (simp add: gf_F_def F_def)
lemma gf_F_le_1:
fixes z :: real
assumes z: "0 ≤ z" "z ≤ 1"
shows "gf_F x y z ≤ 1"
proof -
have "gf_F x y z ≤ gf_F x y 1"
using z unfolding gf_F_def
by (intro suminf_le[OF _ summable_comparison_test[OF _ sums_summable[OF f_sums_F[of x y]]]] mult_left_mono allI f_nonneg)
(simp_all add: power_le_one f_nonneg mult_right_le_one_le f_le_1 sums_summable[OF f_sums_F[of x y]])
also have "… ≤ 1"
by (simp add: gf_F_eq_F F_def)
finally show ?thesis .
qed
lemma u_le_p: "u x y n ≤ p x y (Suc n)"
unfolding u_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)
lemma f_le_p: "f x y n ≤ p x y n"
unfolding f_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)
lemma convergence_norm_U:
fixes z :: "_ :: real_normed_div_algebra"
assumes z: "convergence_G x y z"
shows "summable (λn. u x y n * norm z ^ Suc n)"
using summable_ignore_initial_segment[OF convergence_norm_G[OF z], of 1]
by (rule summable_comparison_test[rotated])
(auto simp add: u_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono u_le_p)
lemma convergence_norm_F:
fixes z :: "_ :: real_normed_div_algebra"
assumes z: "convergence_G x y z"
shows "summable (λn. f x y n * norm z ^ n)"
using convergence_norm_G[OF z]
by (rule summable_comparison_test[rotated])
(auto simp add: f_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono f_le_p)
lemma gf_G_nonneg:
fixes z :: real
shows "0 ≤ z ⟹ z < 1 ⟹ 0 ≤ gf_G x y z"
unfolding gf_G_def
by (intro suminf_nonneg convergence_G convergence_G_less_1) simp_all
lemma gf_F_nonneg:
fixes z :: real
shows "0 ≤ z ⟹ z < 1 ⟹ 0 ≤ gf_F x y z"
unfolding gf_F_def
using convergence_norm_F[OF convergence_G_less_1, of z x y]
by (intro suminf_nonneg) (simp_all add: f_nonneg)
lemma convergence_U:
fixes z :: "_ :: banach"
shows "convergence_G x y z ⟹ summable (λn. u x y n * z ^ Suc n)"
by (rule summable_norm_cancel)
(auto simp add: abs_mult u_nonneg power_abs dest!: convergence_norm_U)
lemma p_eq_sum_p_u: "p x y (Suc n) = (∑i≤n. p y y (n - i) * u x y i)"
proof -
have "⋀ω. ω !! n = y ⟹ (∃i. i ≤ n ∧ ev_at (HLD {y}) i ω)"
proof (induction n)
case (Suc n)
then obtain i where "i ≤ n" "ev_at (HLD {y}) i (stl ω)"
by auto
then show ?case
by (auto intro!: exI[of _ "if HLD {y} ω then 0 else Suc i"])
qed (simp add: HLD_iff)
then have "p x y (Suc n) = (∑i≤n. 𝒫(ω in T x. ev_at (HLD {y}) i ω ∧ ω !! n = y))"
unfolding p_def by (intro T.prob_sum) (auto intro: ev_at_unique)
also have "… = (∑i≤n. p y y (n - i) * u x y i)"
proof (intro sum.cong refl)
fix i assume i: "i ∈ {.. n}"
then have "⋀ω. (Suc i ≤ n ⟶ ω !! (n - Suc i) = y) ⟷ ((y ## ω) !! (n - i) = y)"
by (auto simp: Stream_snth diff_Suc split: nat.split)
from i have "i ≤ n" by auto
then have "𝒫(ω in T x. ev_at (HLD {y}) i ω ∧ ω !! n = y) =
(∫ω'. 𝒫(ω in T y. (y ## ω) !! (n - i) = y) *
indicator {ω'∈space (T x). ev_at (HLD {y}) i ω' } ω' ∂T x)"
by (subst prob_T_split[where n="Suc i"])
(auto simp: ev_at_shift ev_at_HLD_single_imp_snth shift_snth diff_Suc
split: split_indicator nat.split intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure]
simp del: stake.simps integral_mult_right_zero)
then show "𝒫(ω in T x. ev_at (HLD {y}) i ω ∧ ω !! n = y) = p y y (n - i) * u x y i"
by (simp add: p_def u_def)
qed
finally show ?thesis .
qed
lemma p_eq_sum_p_f: "p x y n = (∑i≤n. p y y (n - i) * f x y i)"
by (cases n)
(simp_all del: sum.atMost_Suc
add: f_0 p_0 p_eq_sum_p_u atMost_Suc_eq_insert_0 zero_notin_Suc_image sum.reindex
f_Suc f_Suc_eq)
lemma gf_G_eq_gf_F:
assumes z: "norm z < 1"
shows "gf_G x y z = gf_F x y z * gf_G y y z"
proof -
have "gf_G x y z = (∑n. ∑i≤n. p y y (n - i) * f x y i * z^n)"
by (simp add: gf_G_def p_eq_sum_p_f[of x y] sum_distrib_right)
also have "… = (∑n. ∑i≤n. (f x y i * z^i) * (p y y (n - i) * z^(n - i)))"
by (intro arg_cong[where f=suminf] sum.cong ext atLeast0AtMost[symmetric])
(simp_all add: power_add[symmetric])
also have "… = (∑n. f x y n * z^n) * (∑n. p y y n * z^n)"
using convergence_norm_F[OF convergence_G_less_1[OF z]] convergence_norm_G[OF convergence_G_less_1[OF z]]
by (intro Cauchy_product[symmetric]) (auto simp: f_nonneg abs_mult power_abs)
also have "… = gf_F x y z * gf_G y y z"
by (simp add: gf_F_def gf_G_def)
finally show ?thesis .
qed
lemma gf_G_eq_gf_U:
fixes z :: "'z :: {banach, real_normed_field}"
assumes z: "convergence_G x x z"
shows "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z ≠ 1"
proof -
{ fix n
have "p x x (Suc n) *⇩R z^Suc n = (∑i≤n. (p x x (n - i) * u x x i) *⇩R z^Suc n)"
unfolding scaleR_sum_left[symmetric] by (simp add: p_eq_sum_p_u)
also have "… = (∑i≤n. (u x x i *⇩R z^Suc i) * (p x x (n - i) *⇩R z^(n - i)))"
by (intro sum.cong refl) (simp add: field_simps power_diff cong: disj_cong)
finally have "p x x (Suc n) *⇩R z^(Suc n) = (∑i≤n. (u x x i *⇩R z^Suc i) * (p x x (n - i) *⇩R z^(n - i)))"
unfolding atLeast0AtMost . }
note gfs_Suc_eq = this
have "gf_G x x z = 1 + (∑n. p x x (Suc n) *⇩R z^(Suc n))"
unfolding gf_G_def
by (subst suminf_split_initial_segment[OF convergence_G[OF z], of 1]) simp
also have "… = 1 + (∑n. ∑i≤n. (u x x i *⇩R z^Suc i) * (p x x (n - i) *⇩R z^(n - i)))"
unfolding gfs_Suc_eq ..
also have "… = 1 + gf_U x x z * gf_G x x z"
unfolding gf_U_def gf_G_def
by (subst Cauchy_product)
(auto simp: u_nonneg norm_power simp del: power_Suc
intro!: z convergence_norm_G convergence_norm_U)
finally show "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z ≠ 1"
apply -
apply (cases "gf_U x x z = 1")
apply (auto simp add: field_simps)
done
qed
lemma gf_U: "(gf_U x y ⤏ U x y) (at_left 1)"
proof -
have "((λz. ennreal (∑n. u x y n * z ^ n)) ⤏ (∑n. ennreal (u x y n))) (at_left 1)"
using u_le_1 u_nonneg by (intro power_series_tendsto_at_left summable_power_series)
also have "(∑n. ennreal (u x y n)) = ennreal (suminf (u x y))"
by (intro u_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF u_sums_U])
also have "suminf (u x y) = U x y"
using u_sums_U by (rule sums_unique[symmetric])
finally have "((λz. ∑n. u x y n * z ^ n) ⤏ U x y) (at_left 1)"
by (rule tendsto_ennrealD)
(auto simp: u_nonneg u_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
then have "((λz. z * (∑n. u x y n * z ^ n)) ⤏ 1 * U x y) (at_left 1)"
by (intro tendsto_intros) simp
then have "((λz. ∑n. u x y n * z ^ Suc n) ⤏ 1 * U x y) (at_left 1)"
apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
apply (rule eventually_at_left_1)
apply (subst suminf_mult[symmetric])
apply (auto intro!: summable_power_series u_le_1 u_nonneg)
apply (simp add: field_simps)
done
then show ?thesis
by (simp add: gf_U_def[abs_def] U_def)
qed
lemma gf_U_le_1: assumes z: "0 < z" "z < 1" shows "gf_U x y z ≤ (1::real)"
proof -
note u = u_sums_U[of x y, THEN sums_summable]
have "gf_U x y z ≤ gf_U x y 1"
using z
unfolding gf_U_def real_scaleR_def
by (intro suminf_le allI mult_mono power_mono summable_comparison_test_ev[OF _ u] always_eventually)
(auto simp: u_nonneg intro!: mult_left_le mult_le_one power_le_one)
also have "… ≤ 1"
unfolding gf_U_eq_U by (rule U_le_1)
finally show ?thesis .
qed
lemma gf_F: "(gf_F x y ⤏ F x y) (at_left 1)"
proof -
have "((λz. ennreal (∑n. f x y n * z ^ n)) ⤏ (∑n. ennreal (f x y n))) (at_left 1)"
using f_le_1 f_nonneg by (intro power_series_tendsto_at_left summable_power_series)
also have "(∑n. ennreal (f x y n)) = ennreal (suminf (f x y))"
by (intro f_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF f_sums_F])
also have "suminf (f x y) = F x y"
using f_sums_F by (rule sums_unique[symmetric])
finally have "((λz. ∑n. f x y n * z ^ n) ⤏ F x y) (at_left 1)"
by (rule tendsto_ennrealD)
(auto simp: f_nonneg f_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
then show ?thesis
by (simp add: gf_F_def[abs_def] F_def)
qed
lemma U_bounded: "0 ≤ U x y" "U x y ≤ 1"
unfolding U_def by simp_all
subsection ‹Recurrent states›
definition recurrent :: "'s ⇒ bool" where
"recurrent s ⟷ (AE ω in T s. ev (HLD {s}) ω)"
lemma recurrent_iff_U_eq_1: "recurrent s ⟷ U s s = 1"
unfolding recurrent_def U_def by (subst T.prob_Collect_eq_1) simp_all
definition "H s t = 𝒫(ω in T s. alw (ev (HLD {t})) ω)"
lemma H_eq:
"recurrent s ⟷ H s s = 1"
"¬ recurrent s ⟷ H s s = 0"
"H s t = U s t * H t t"
proof -
define H' where "H' t n = {ω∈space S. enat n ≤ scount (HLD {t::'s}) ω}" for t n
have [measurable]: "⋀y n. H' y n ∈ sets S"
by (simp add: H'_def)
let ?H' = "λs t n. measure (T s) (H' t n)"
{ fix x y :: 's and ω
have "Suc 0 ≤ scount (HLD {y}) ω ⟷ ev (HLD {y}) ω"
using scount_eq_0_iff[of "HLD {y}" ω]
by (cases "scount (HLD {y}) ω" rule: enat_coexhaust)
(auto simp: not_ev_iff[symmetric] eSuc_enat[symmetric] enat_0 HLD_iff[abs_def]) }
then have H'_1: "⋀x y. ?H' x y 1 = U x y"
unfolding H'_def U_def by simp
{ fix n and x y :: 's
let ?U = "(not (HLD {y}) suntil (HLD {y} aand nxt (λω. enat n ≤ scount (HLD {y}) ω)))"
{ fix ω
have "enat (Suc n) ≤ scount (HLD {y}) ω ⟷ ?U ω"
proof
assume "enat (Suc n) ≤ scount (HLD {y}) ω"
with scount_eq_0_iff[of "HLD {y}" ω] have "ev (HLD {y}) ω" "enat (Suc n) ≤ scount (HLD {y}) ω"
by (auto simp add: not_ev_iff[symmetric] eSuc_enat[symmetric])
then show "?U ω"
by (induction rule: ev_induct_strong)
(auto simp: scount_simps eSuc_enat[symmetric] intro: suntil.intros)
next
assume "?U ω" then show "enat (Suc n) ≤ scount (HLD {y}) ω"
by induction (auto simp: scount_simps eSuc_enat[symmetric])
qed }
then have "emeasure (T x) (H' y (Suc n)) = emeasure (T x) {ω∈space (T x). ?U ω}"
by (simp add: H'_def)
also have "… = U x y * ?H' y y n"
by (subst emeasure_suntil_HLD) (simp_all add: T.emeasure_eq_measure U_def H'_def ennreal_mult)
finally have "?H' x y (Suc n) = U x y * ?H' y y n"
by (simp add: T.emeasure_eq_measure) }
note H'_Suc = this
{ fix m and x :: 's
have "?H' x x (Suc m) = U x x^Suc m"
using H'_1 H'_Suc by (induct m) auto }
note H'_eq = this
{ fix x y
have "?H' x y ⇢ measure (T x) (⋂i. H' y i)"
apply (rule T.finite_Lim_measure_decseq)
apply safe
apply simp
apply (auto simp add: decseq_Suc_iff subset_eq H'_def eSuc_enat[symmetric]
intro: ile_eSuc order_trans)
done
also have "(⋂i. H' y i) = {ω∈space (T x). alw (ev (HLD {y})) ω}"
by (auto simp: H'_def scount_infinite_iff[symmetric]) (metis Suc_ile_eq enat.exhaust neq_iff)
finally have "?H' x y ⇢ H x y"
unfolding H_def . }
note H'_lim = this
from H'_lim[of s s, THEN LIMSEQ_Suc]
have "(λn. U s s ^ Suc n) ⇢ H s s"
by (simp add: H'_eq)
then have lim_H: "(λn. U s s ^ n) ⇢ H s s"
by (rule LIMSEQ_imp_Suc)
have "U s s < 1 ⟹ (λn. U s s ^ n) ⇢ 0"
by (rule LIMSEQ_realpow_zero) (simp_all add: U_def)
with lim_H have "U s s < 1 ⟹ H s s = 0"
by (blast intro: LIMSEQ_unique)
moreover have "U s s = 1 ⟹ (λn. U s s ^ n) ⇢ 1"
by simp
with lim_H have "U s s = 1 ⟹ H s s = 1"
by (blast intro: LIMSEQ_unique)
moreover note recurrent_iff_U_eq_1 U_cases
ultimately show "recurrent s ⟷ H s s = 1" "¬ recurrent s ⟷ H s s = 0"
by (metis one_neq_zero)+
from H'_lim[of s t, THEN LIMSEQ_Suc] H'_Suc[of s]
have "(λn. U s t * ?H' t t n) ⇢ H s t"
by simp
moreover have "(λn. U s t * ?H' t t n) ⇢ U s t * H t t"
by (intro tendsto_intros H'_lim)
ultimately show "H s t = U s t * H t t"
by (blast intro: LIMSEQ_unique)
qed
lemma recurrent_iff_G_infinite: "recurrent x ⟷ G x x = ∞"
proof -
have "((λz. ennreal (gf_G x x z)) ⤏ G x x) (at_left 1)"
by (rule lim_gf_G)
then have G: "((λz. ennreal (1 / (1 - gf_U x x z))) ⤏ G x x) (at_left (1::real))"
apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
apply (rule eventually_at_left_1)
apply (subst gf_G_eq_gf_U)
apply (rule convergence_G_less_1)
apply simp
apply simp
done
{ fix z :: real assume z: "0 < z" "z < 1"
have 1: "summable (u x x)"
using u_sums_U by (rule sums_summable)
have "gf_U x x z ≠ 1"
using gf_G_eq_gf_U[OF convergence_G_less_1[of z]] z by simp
moreover
have "gf_U x x z ≤ U x x"
unfolding gf_U_def gf_U_eq_U[symmetric]
using z
by (intro suminf_le)
(auto simp add: 1 convergence_U convergence_G_less_1 u_nonneg simp del: power_Suc
intro!: mult_right_le_one_le power_le_one)
ultimately have "gf_U x x z < 1"
using U_bounded[of x x] by simp }
note strict = this
{ assume "U x x = 1"
moreover have "((λxa. 1 - gf_U x x xa :: real) ⤏ 1 - U x x) (at_left 1)"
by (intro tendsto_intros gf_U)
moreover have "eventually (λz. gf_U x x z < 1) (at_left (1::real))"
by (auto intro!: eventually_at_left_1 strict simp: ‹U x x = 1› gf_U_eq_U)
ultimately have "((λz. ennreal (1 / (1 - gf_U x x z))) ⤏ top) (at_left 1)"
unfolding ennreal_tendsto_top_eq_at_top
by (intro LIM_at_top_divide[where a=1] tendsto_const zero_less_one)
(auto simp: field_simps)
with G have "G x x = top"
by (rule tendsto_unique[rotated]) simp }
moreover
{ assume "U x x < 1"
then have "((λxa. ennreal (1 / (1 - gf_U x x xa))) ⤏ 1 / (1 - U x x)) (at_left 1)"
by (intro tendsto_intros gf_U tendsto_ennrealI) simp
from tendsto_unique[OF _ G this] have "G x x ≠ ∞"
by simp }
ultimately show ?thesis
using U_cases recurrent_iff_U_eq_1 by auto
qed
definition communicating :: "('s × 's) set" where
"communicating = acc ∩ acc¯"
definition essential_class :: "'s set ⇒ bool" where
"essential_class C ⟷ C ∈ UNIV // communicating ∧ acc `` C ⊆ C"
lemma accI_U:
assumes "0 < U x y" shows "(x, y) ∈ acc"
proof (rule ccontr)
assume *: "(x, y) ∉ acc"
{ fix ω assume "ev (HLD {y}) ω" "alw (HLD (acc `` {x})) ω" from this * have False
by induction (auto simp: HLD_iff) }
with AE_T_reachable[of x] have "U x y = 0"
unfolding U_def by (intro T.prob_eq_0_AE) auto
with ‹0 < U x y› show False by auto
qed
lemma accD_pos:
assumes "(x, y) ∈ acc"
shows "∃n. 0 < p x y n"
using assms proof induction
case base with T.prob_space[of x] show ?case
by (auto intro!: exI[of _ 0])
next
have [simp]: "⋀x y. (if x = y then 1 else 0::real) = indicator {y} x"
by simp
case (step w y)
then obtain n where "0 < p x w n" and "0 < pmf (K w) y"
by (auto simp: set_pmf_iff less_le)
then have "0 < p x w n * pmf (K w) y"
by (intro mult_pos_pos)
also have "… ≤ p x w n * p w y (Suc 0)"
by (simp add: p_Suc' p_0 pmf.rep_eq)
also have "… ≤ p x y (Suc n)"
using prob_reachable_le[of n "Suc n" x w y] by simp
finally show ?case ..
qed
lemma accI_pos: "0 < p x y n ⟹ (x, y) ∈ acc"
proof (induct n arbitrary: x)
case (Suc n)
then have less: "0 < (∫x'. p x' y n ∂K x)"
by (simp add: p_Suc')
have "∃x'∈K x. 0 < p x' y n"
proof (rule ccontr)
assume "¬ ?thesis"
then have "AE x' in K x. p x' y n = 0"
by (simp add: AE_measure_pmf_iff less_le)
then have "(∫x'. p x' y n ∂K x) = (∫x'. 0 ∂K x)"
by (intro integral_cong_AE) simp_all
with less show False by simp
qed
with Suc show ?case
by (auto intro: converse_rtrancl_into_rtrancl)
qed (simp add: p_0 split: if_split_asm)
lemma recurrent_iffI_communicating:
assumes "(x, y) ∈ communicating"
shows "recurrent x ⟷ recurrent y"
proof -
from assms obtain n m where "0 < p x y n" "0 < p y x m"
by (force simp: communicating_def dest: accD_pos)
moreover
{ fix x y n m assume "0 < p x y n" "0 < p y x m" "G y y = ∞"
then have "∞ = ennreal (p x y n * p y x m) * G y y"
by (auto intro: mult_pos_pos simp: ennreal_mult_top)
also have "ennreal (p x y n * p y x m) * G y y = (∑i. ennreal (p x y n * p y x m) * p y y i)"
unfolding G_eq_suminf by (rule ennreal_suminf_cmult[symmetric])
also have "… ≤ (∑i. ennreal (p x x (n + i + m)))"
proof (intro suminf_le allI)
fix i
have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i)) ≤ p x y (n + i) * p y x ((n + i + m) - (n + i))"
by (intro mult_right_mono prob_reachable_le) simp_all
also have "… ≤ p x x (n + i + m)"
by (intro prob_reachable_le) simp_all
finally show "ennreal (p x y n * p y x m) * p y y i ≤ ennreal (p x x (n + i + m))"
by (simp add: ac_simps ennreal_mult'[symmetric])
qed auto
also have "… ≤ (∑i. ennreal (p x x (i + (n + m))))"
by (simp add: ac_simps)
also have "… ≤ (∑i. ennreal (p x x i))"
by (subst suminf_offset[of "λi. ennreal (p x x i)" "n + m"]) auto
also have "… ≤ G x x"
unfolding G_eq_suminf by (auto intro!: suminf_le_pos)
finally have "G x x = ∞"
by (simp add: top_unique) }
ultimately show ?thesis
using recurrent_iff_G_infinite by blast
qed
lemma recurrent_acc:
assumes "recurrent x" "(x, y) ∈ acc"
shows "U y x = 1" "H y x = 1" "recurrent y" "(x, y) ∈ communicating"
proof -
{ fix w y assume step: "(x, w) ∈ acc" "y ∈ K w" "U w x = 1" "H w x = 1" "recurrent w" "x ≠ y"
have "measure (K w) UNIV = U w x"
using step measure_pmf.prob_space[of "K w"] by simp
also have "… = (∫v. indicator {x} v + U v x * indicator (- {x}) v ∂K w)"
unfolding U_def
by (subst prob_T)
(auto intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure] AE_I2
simp: ev_Stream T.prob_eq_1 split: split_indicator)
also have "… = measure (K w) {x} + (∫v. U v x * indicator (- {x}) v ∂K w)"
by (subst Bochner_Integration.integral_add)
(auto intro!: measure_pmf.integrable_const_bound[where B=1]
simp: abs_mult mult_le_one U_bounded(2) measure_pmf.emeasure_eq_measure)
finally have "measure (K w) UNIV - measure (K w) {x} = (∫v. U v x * indicator (- {x}) v ∂K w)"
by simp
also have "measure (K w) UNIV - measure (K w) {x} = measure (K w) (UNIV - {x})"
by (subst measure_pmf.finite_measure_Diff) auto
finally have "0 = (∫v. indicator (- {x}) v ∂K w) - (∫v. U v x * indicator (- {x}) v ∂K w)"
by (simp add: measure_pmf.emeasure_eq_measure Compl_eq_Diff_UNIV)
also have "… = (∫v. (1 - U v x) * indicator (- {x}) v ∂K w)"
by (subst Bochner_Integration.integral_diff[symmetric])
(auto intro!: measure_pmf.integrable_const_bound[where B=1] Bochner_Integration.integral_cong
simp: abs_mult mult_le_one U_bounded(2) split: split_indicator)
also have "… ≥ (∫v. (1 - U y x) * indicator {y} v ∂K w)" (is "_ ≥ ?rhs")
using ‹recurrent x›
by (intro integral_mono measure_pmf.integrable_const_bound[where B=1])
(auto simp: abs_mult mult_le_one U_bounded(2) recurrent_iff_U_eq_1 field_simps
split: split_indicator)
also (xtrans) have "?rhs = (1 - U y x) * pmf (K w) y"
by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)
finally have "(1 - U y x) * pmf (K w) y = 0"
by (auto intro!: antisym simp: U_bounded(2) mult_le_0_iff)
with ‹y ∈ K w› have "U y x = 1"
by (simp add: set_pmf_iff)
then have "U y x = 1" "H y x = 1"
using H_eq(3)[of y x] H_eq(1)[of x] by (simp_all add: ‹recurrent x›)
then have "(y, x) ∈ acc"
by (intro accI_U) auto
with step have "(x, y) ∈ communicating"
by (auto simp add: communicating_def intro: rtrancl_trans)
with ‹recurrent x› have "recurrent y"
by (simp add: recurrent_iffI_communicating)
note this ‹U y x = 1› ‹H y x = 1› ‹(x, y) ∈ communicating› }
note enabled = this
from ‹(x, y) ∈ acc›
show "U y x = 1" "H y x = 1" "recurrent y" "(x, y) ∈ communicating"
proof induction
case base then show "U x x = 1" "H x x = 1" "recurrent x" "(x, x) ∈ communicating"
using ‹recurrent x› H_eq(1)[of x] by (auto simp: recurrent_iff_U_eq_1 communicating_def)
next
case (step w y)
with enabled[of w y] ‹recurrent x› H_eq(1)[of x]
have "U y x = 1 ∧ H y x = 1 ∧ recurrent y ∧ (x, y) ∈ communicating"
by (cases "x = y") (auto simp: recurrent_iff_U_eq_1 communicating_def)
then show "U y x = 1" "H y x = 1" "recurrent y" "(x, y) ∈ communicating"
by auto
qed
qed
lemma equiv_communicating: "equiv UNIV communicating"
by (auto simp: equiv_def sym_def communicating_def refl_on_def trans_def)
lemma recurrent_class:
assumes "recurrent x"
shows "acc `` {x} = communicating `` {x}"
using recurrent_acc(4)[OF ‹recurrent x›] by (auto simp: communicating_def)
lemma irreduccible_recurrent_class:
assumes "recurrent x" shows "acc `` {x} ∈ UNIV // communicating"
unfolding recurrent_class[OF ‹recurrent x›] by (rule quotientI) simp
lemma essential_classI:
assumes C: "C ∈ UNIV // communicating"
assumes eq: "⋀x y. x ∈ C ⟹ (x, y) ∈ acc ⟹ y ∈ C"
shows "essential_class C"
by (auto simp: essential_class_def intro: C) (metis eq)
lemma essential_recurrent_class:
assumes "recurrent x" shows "essential_class (communicating `` {x})"
unfolding recurrent_class[OF ‹recurrent x›, symmetric]
apply (rule essential_classI)
apply (rule irreduccible_recurrent_class[OF assms])
apply (auto simp: communicating_def)
done
lemma essential_classD2:
"essential_class C ⟹ x ∈ C ⟹ (x, y) ∈ acc ⟹ y ∈ C"
unfolding essential_class_def by auto
lemma essential_classD3:
"essential_class C ⟹ x ∈ C ⟹ y ∈ C ⟹ (x, y) ∈ communicating"
unfolding essential_class_def
by (auto elim!: quotientE simp: communicating_def)
lemma AE_acc:
shows "AE ω in T x. ∀m. (x, (x ## ω) !! m) ∈ acc"
using AE_T_reachable
by eventually_elim (auto simp: alw_HLD_iff_streams streams_iff_snth Stream_snth split: nat.splits)
lemma finite_essential_class_imp_recurrent:
assumes C: "essential_class C" "finite C" and x: "x ∈ C"
shows "recurrent x"
proof -
have "AE ω in T x. ∃y∈C. alw (ev (HLD {y})) ω"
using AE_T_reachable
proof eventually_elim
fix ω assume "alw (HLD (acc `` {x})) ω"
then have "alw (HLD C) ω"
by (rule alw_mono) (auto simp: HLD_iff intro: assms essential_classD2)
then show "∃y∈C. alw (ev (HLD {y})) ω"
by (rule pigeonhole_stream) fact
qed
then have "1 = 𝒫(ω in T x. ∃y∈C. alw (ev (HLD {y})) ω)"
by (subst (asm) T.prob_Collect_eq_1[symmetric]) (auto simp: ‹finite C›)
also have "… = measure (T x) (⋃y∈C. {ω∈space (T x). alw (ev (HLD {y})) ω})"
by (intro arg_cong2[where f=measure]) auto
also have "… ≤ (∑y∈C. H x y)"
unfolding H_def using ‹finite C› by (rule T.finite_measure_subadditive_finite) auto
also have "… = (∑y∈C. U x y * H y y)"
by (auto intro!: sum.cong H_eq)
finally have "∃y∈C. recurrent y"
by (rule_tac ccontr) (simp add: H_eq(2))
then guess y ..
from essential_classD3[OF C(1) x this(1)] recurrent_acc(3)[OF this(2)]
show "recurrent x"
by (simp add: communicating_def)
qed
lemma irreducibleD:
"C ∈ UNIV // communicating ⟹ a ∈ C ⟹ b ∈ C ⟹ (a, b) ∈ communicating"
by (auto elim!: quotientE simp: communicating_def)
lemma irreducibleD2:
"C ∈ UNIV // communicating ⟹ a ∈ C ⟹ (a, b) ∈ communicating ⟹ b ∈ C"
by (auto elim!: quotientE simp: communicating_def)
lemma essential_class_iff_recurrent:
"finite C ⟹ C ∈ UNIV // communicating ⟹ essential_class C ⟷ (∀x∈C. recurrent x)"
by (metis finite_essential_class_imp_recurrent irreducibleD2 recurrent_acc(4) essential_classI)
definition "U' x y = (∫⇧+ω. eSuc (sfirst (HLD {y}) ω) ∂T x)"
lemma U'_neq_zero[simp]: "U' x y ≠ 0"
unfolding U'_def by (simp add: nn_integral_add)
definition "gf_U' x y z = (∑n. u x y n * Suc n * z ^ n)"
definition "pos_recurrent x ⟷ recurrent x ∧ U' x x ≠ ∞"
lemma summable_gf_U':
assumes z: "norm z < 1"
shows "summable (λn. u x y n * Suc n * z ^ n)"
proof -
have "summable (λn. n * ¦z¦ ^ n)"
proof (rule root_test_convergence)
have "(λn. root n n * ¦z¦) ⇢ 1 * ¦z¦"
by (intro tendsto_intros LIMSEQ_root)
then show "(λn. root n (norm (n * ¦z¦ ^ n))) ⇢ ¦z¦"
by (rule filterlim_cong[THEN iffD1, rotated 3])
(auto intro!: exI[of _ 1]
simp add: abs_mult u_nonneg real_root_mult power_abs eventually_sequentially real_root_power)
qed (insert z, simp add: abs_less_iff)
note summable_mult[OF this, of "1 / ¦z¦"]
from summable_ignore_initial_segment[OF this, of 1]
show "summable (λn. u x y n * Suc n * z ^ n)"
apply (rule summable_comparison_test[rotated])
using z
apply (auto intro!: exI[of _ 1]
simp: abs_mult u_nonneg power_abs Suc_le_eq gr0_conv_Suc field_simps le_divide_eq u_le_1
simp del: of_nat_Suc)
done
qed
lemma gf_U'_nonneg[simp]: "0 < z ⟹ z < 1 ⟹ 0 ≤ gf_U' x y z"
unfolding gf_U'_def
by (intro suminf_nonneg summable_gf_U') (auto simp: u_nonneg)
lemma DERIV_gf_U:
fixes z :: real assumes z: "0 < z" "z < 1"
shows "DERIV (gf_U x y) z :> gf_U' x y z"
unfolding gf_U_def[abs_def] gf_U'_def real_scaleR_def u_def[symmetric]
using z by (intro DERIV_power_series'[where R=1] summable_gf_U') auto
lemma sfirst_finiteI_recurrent:
"recurrent x ⟹ (x, y) ∈ acc ⟹ AE ω in T x. sfirst (HLD {y}) ω < ∞"
using recurrent_acc(1)[of y x] recurrent_acc[of x y]
T.AE_prob_1[of x "{ω∈space (T x). ev (HLD {y}) ω}"]
unfolding sfirst_finite U_def by (simp add: space_stream_space communicating_def)
lemma U'_eq_suminf:
assumes x: "recurrent x" "(x, y) ∈ acc"
shows "U' x y = (∑i. ennreal (u x y i * Suc i))"
proof -
have "(∫⇧+ω. eSuc (sfirst (HLD {y}) ω) ∂T x) =
(∫⇧+ω. (∑i. ennreal (Suc i) * indicator {ω∈space (T y). ev_at (HLD {y}) i ω} ω) ∂T x)"
using sfirst_finiteI_recurrent[OF x]
proof (intro nn_integral_cong_AE, eventually_elim)
fix ω assume "sfirst (HLD {y}) ω < ∞"
then obtain n :: nat where [simp]: "sfirst (HLD {y}) ω = n"
by auto
show "eSuc (sfirst (HLD {y}) ω) = (∑i. ennreal (Suc i) * indicator {ω∈space (T y). ev_at (HLD {y}) i ω} ω)"
by (subst suminf_cmult_indicator[where i=n])
(auto simp: disjoint_family_on_def ev_at_unique space_stream_space
sfirst_eq_enat_iff[symmetric] ennreal_of_nat_eq_real_of_nat
split: split_indicator)
qed
also have "… = (∑i. ennreal (Suc i) * emeasure (T x) {ω∈space (T x). ev_at (HLD {y}) i ω})"
by (subst nn_integral_suminf)
(auto intro!: arg_cong[where f=suminf] nn_integral_cmult_indicator simp: fun_eq_iff)
finally show ?thesis
by (simp add: U'_def u_def T.emeasure_eq_measure mult_ac ennreal_mult)
qed
lemma gf_U'_tendsto_U':
assumes x: "recurrent x" "(x, y) ∈ acc"
shows "((λz. ennreal (gf_U' x y z)) ⤏ U' x y) (at_left 1)"
unfolding U'_eq_suminf[OF x] gf_U'_def
by (auto intro!: power_series_tendsto_at_left summable_gf_U' mult_nonneg_nonneg u_nonneg simp del: of_nat_Suc)
lemma one_le_integral_t:
assumes x: "recurrent x" shows "1 ≤ U' x x"
by (simp add: nn_integral_add T.emeasure_space_1 U'_def del: space_T)
lemma gf_U'_pos:
fixes z :: real
assumes z: "0 < z" "z < 1" and "U x y ≠ 0"
shows "0 < gf_U' x y z"
unfolding gf_U'_def
proof (subst suminf_pos_iff)
show "summable (λn. u x y n * real (Suc n) * z ^ n)"
using z by (intro summable_gf_U') simp
show pos: "⋀n. 0 ≤ u x y n * real (Suc n) * z ^ n"
using u_nonneg z by auto
show "∃n. 0 < u x y n * real (Suc n) * z ^ n"
proof (rule ccontr)
assume "¬ (∃n. 0 < u x y n * real (Suc n) * z ^ n)"
with pos have "∀n. u x y n * real (Suc n) * z ^ n = 0"
by (intro antisym allI) (simp_all add: not_less)
with z have "u x y = (λn. 0)"
by (intro ext) simp
with u_sums_U[of x y, THEN sums_unique] ‹U x y ≠ 0› show False
by simp
qed
qed
lemma inverse_gf_U'_tendsto:
assumes "recurrent y"
shows "((λx. - 1 / - gf_U' y y x) ⤏ enn2real (1 / U' y y)) (at_left (1::real))"
proof cases
assume inf: "U' y y = ∞"
with gf_U'_tendsto_U'[of y y] ‹recurrent y›
have "LIM z (at_left 1). gf_U' y y z :> at_top"
by (auto simp: ennreal_tendsto_top_eq_at_top U'_def)
then have "LIM z (at_left 1). gf_U' y y z :> at_infinity"
by (rule filterlim_mono) (auto simp: at_top_le_at_infinity)
with inf show ?thesis
by (auto intro!: tendsto_divide_0)
next
assume fin: "U' y y ≠ ∞"
then obtain r where r: "U' y y = ennreal r" and [simp]: "0 ≤ r"
by (cases "U' y y") (auto simp: U'_def)
then have eq: "enn2real (1 / U' y y) = - 1 / - r" and "1 ≤ r"
using one_le_integral_t[OF ‹recurrent y›]
by (auto simp add: ennreal_1[symmetric] divide_ennreal simp del: ennreal_1)
have "((λz. ennreal (gf_U' y y z)) ⤏ ennreal r) (at_left 1)"
using gf_U'_tendsto_U'[OF ‹recurrent y›, of y] r by simp
then have gf_U': "(gf_U' y y ⤏ r) (at_left (1::real))"
by (rule tendsto_ennrealD)
(insert summable_gf_U', auto intro!: eventually_at_left_1 suminf_nonneg simp: gf_U'_def u_nonneg)
show ?thesis
using ‹1 ≤ r› unfolding eq by (intro tendsto_intros gf_U') simp
qed
lemma gf_G_pos:
fixes z :: real
assumes z: "0 < z" "z < 1" and *: "(x, y) ∈ acc"
shows "0 < gf_G x y z"
unfolding gf_G_def
proof (subst suminf_pos_iff)
show "summable (λn. p x y n *⇩R z ^ n)"
using z by (intro convergence_G convergence_G_less_1) simp
show pos: "⋀n. 0 ≤ p x y n *⇩R z ^ n"
using z by (auto intro!: mult_nonneg_nonneg p_nonneg)
show "∃n. 0 < p x y n *⇩R z ^ n"
proof (rule ccontr)
assume "¬ (∃n. 0 < p x y n *⇩R z ^ n)"
with pos have "∀n. p x y n * z ^ n = 0"
by (intro antisym allI) (simp_all add: not_less)
with z have "⋀n. p x y n = 0"
by simp
with *[THEN accD_pos] show False
by simp
qed
qed
lemma pos_recurrentI_communicating:
assumes y: "pos_recurrent y" and x: "(y, x) ∈ communicating"
shows "pos_recurrent x"
proof -
from y x have recurrent: "recurrent y" "recurrent x" and fin: "U' y y ≠ ∞"
by (auto simp: pos_recurrent_def recurrent_iffI_communicating nn_integral_add)
have pos: "0 < enn2real (1 / U' y y)"
using one_le_integral_t[OF ‹recurrent y›] fin
by (auto simp: U'_def enn2real_positive_iff less_top[symmetric] ennreal_zero_less_divide ennreal_divide_eq_top_iff)
from fin obtain r where r: "U' y y = ennreal r" and [simp]: "0 ≤ r"
by (cases "U' y y") (auto simp: U'_def)
from x obtain n m where "0 < p x y n" "0 < p y x m"
by (auto dest!: accD_pos simp: communicating_def)
let ?L = "at_left (1::real)"
have le: "eventually (λz. p x y n * p y x m * z^(n + m) ≤ (1 - gf_U y y z) / (1 - gf_U x x z)) ?L"
proof (rule eventually_at_left_1)
fix z :: real assume z: "0 < z" "z < 1"
then have conv: "⋀x. convergence_G x x z"
by (intro convergence_G_less_1) simp
have sums: "(λi. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i)) sums ((p x y n * p y x m * z^(n + m)) * gf_G y y z)"
unfolding gf_G_def
by (intro sums_mult summable_sums) (auto intro!: conv convergence_G[where 'a=real, simplified])
have "(∑i. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i)) ≤ (∑i. p x x (i + (n + m)) * z^(i + (n + m)))"
proof (intro allI suminf_le sums_summable[OF sums] summable_ignore_initial_segment convergence_G[where 'a=real, simplified] convergence_G_less_1)
show "norm z < 1" using z by simp
fix i
have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i)) ≤ p x y (n + i) * p y x ((n + i + m) - (n + i))"
by (intro mult_right_mono prob_reachable_le) simp_all
also have "… ≤ p x x (n + i + m)"
by (intro prob_reachable_le) simp_all
finally show "p x y n * p y x m * z ^ (n + m) * (p y y i * z ^ i) ≤ p x x (i + (n + m)) * z ^ (i + (n + m))"
using z by (auto simp add: ac_simps power_add intro!: mult_left_mono)
qed
also have "… ≤ gf_G x x z"
unfolding gf_G_def
using z
apply (subst (2) suminf_split_initial_segment[where k="n + m"])
apply (intro convergence_G conv)
apply (simp add: sum_nonneg)
done
finally have "(p x y n * p y x m * z^(n + m)) * gf_G y y z ≤ gf_G x x z"
using sums_unique[OF sums] by simp
then have "(p x y n * p y x m * z^(n + m)) ≤ gf_G x x z / gf_G y y z"
using z gf_G_pos[of z y y] by (simp add: field_simps)
also have "… = (1 - gf_U y y z) / (1 - gf_U x x z)"
unfolding gf_G_eq_gf_U[OF conv] using gf_G_eq_gf_U(2)[OF conv] by (simp add: field_simps )
finally show "p x y n * p y x m * z^(n + m) ≤ (1 - gf_U y y z) / (1 - gf_U x x z)" .
qed
have "U' x x ≠ ∞"
proof
assume "U' x x = ∞"
have "((λz. (1 - gf_U y y z) / (1 - gf_U x x z)) ⤏ 0) ?L"
proof (rule lhopital_left)
show "((λz. 1 - gf_U y y z) ⤏ 0) ?L"
using gf_U[of y] recurrent_iff_U_eq_1[of y] ‹recurrent y› by (auto intro!: tendsto_eq_intros)
show "((λz. 1 - gf_U x x z) ⤏ 0) ?L"
using gf_U[of x] recurrent_iff_U_eq_1[of x] ‹recurrent x› by (auto intro!: tendsto_eq_intros)
show "eventually (λz. 1 - gf_U x x z ≠ 0) ?L"
by (auto intro!: eventually_at_left_1 simp: gf_G_eq_gf_U(2) convergence_G_less_1)
show "eventually (λz. - gf_U' x x z ≠ 0) ?L"
using gf_U'_pos[of _ x x] recurrent_iff_U_eq_1[of x] ‹recurrent x›
by (auto intro!: eventually_at_left_1) (metis less_le)
show "eventually (λz. DERIV (λxa. 1 - gf_U x x xa) z :> - gf_U' x x z) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
show "eventually (λz. DERIV (λxa. 1 - gf_U y y xa) z :> - gf_U' y y z) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
have "(gf_U' y y ⤏ U' y y) ?L"
using ‹recurrent y› by (rule gf_U'_tendsto_U') simp
then have *: "(gf_U' y y ⤏ r) ?L"
by (auto simp add: r eventually_at_left_1 dest!: tendsto_ennrealD)
moreover
have "(gf_U' x x ⤏ U' x x) ?L"
using ‹recurrent x› by (rule gf_U'_tendsto_U') simp
then have "LIM z ?L. - gf_U' x x z :> at_bot"
by (simp add: ennreal_tendsto_top_eq_at_top ‹U' x x = ∞› filterlim_uminus_at_top
del: ennreal_of_enat_eSuc)
then have "LIM z ?L. - gf_U' x x z :> at_infinity"
by (rule filterlim_mono) (auto simp: at_bot_le_at_infinity)
ultimately show "((λz. - gf_U' y y z / - gf_U' x x z) ⤏ 0) ?L"
by (intro tendsto_divide_0[where c="- r"] tendsto_intros)
qed
moreover
have "((λz. p x y n * p y x m * z^(n + m)) ⤏ p x y n * p y x m) ?L"
by (auto intro!: tendsto_eq_intros)
ultimately have "p x y n * p y x m ≤ 0"
using le by (rule tendsto_le[OF trivial_limit_at_left_real])
with ‹0 < p x y n› ‹0 < p y x m› show False
by (auto simp add: mult_le_0_iff)
qed
with ‹recurrent x› show ?thesis
by (simp add: pos_recurrent_def nn_integral_add)
qed
lemma pos_recurrent_iffI_communicating:
"(y, x) ∈ communicating ⟹ pos_recurrent y ⟷ pos_recurrent x"
using pos_recurrentI_communicating[of x y] pos_recurrentI_communicating[of y x]
by (auto simp add: communicating_def)
lemma U_le_F: "U x y ≤ F x y"
by (auto simp: U_def F_def intro!: T.finite_measure_mono)
lemma not_empty_irreducible: "C ∈ UNIV // communicating ⟹ C ≠ {}"
by (auto simp: quotient_def Image_def communicating_def)
subsection ‹Stationary distribution›
definition stat :: "'s set ⇒ 's measure" where
"stat C = point_measure UNIV (λx. indicator C x / U' x x)"
lemma sets_stat[simp]: "sets (stat C) = sets (count_space UNIV)"
by (simp add: stat_def sets_point_measure)
lemma space_stat[simp]: "space (stat C) = UNIV"
by (simp add: stat_def space_point_measure)
lemma stat_subprob:
assumes C: "essential_class C" and "countable C" and pos: "∀c∈C. pos_recurrent c"
shows "emeasure (stat C) C ≤ 1"
proof -
let ?L = "at_left (1::real)"
from finite_sequence_to_countable_set[OF ‹countable C›] guess A . note A = this
then have "(λn. emeasure (stat C) (A n)) ⇢ emeasure (stat C) (⋃i. A i)"
by (intro Lim_emeasure_incseq) (auto simp: incseq_Suc_iff)
then have "emeasure (stat C) (⋃i. A i) ≤ 1"
proof (rule LIMSEQ_le[OF _ tendsto_const], intro exI allI impI)
fix n
from A(1,3) have A_n: "finite (A n)"
by auto
from C have "C ≠ {}"
by (simp add: essential_class_def not_empty_irreducible)
then obtain x where "x ∈ C" by auto
have "((λz. (∑y∈A n. gf_F x y z * ((1 - z) / (1 - gf_U y y z)))) ⤏ (∑y∈A n. F x y * enn2real (1 / U' y y))) ?L"
proof (intro tendsto_intros gf_F, rule lhopital_left)
fix y assume "y ∈ A n"
with ‹A n ⊆ C› have "y ∈ C"
by auto
show "((-) 1 ⤏ 0) ?L"
by (intro tendsto_eq_intros) simp_all
have "recurrent y"
using pos[THEN bspec, OF ‹y∈C›] by (simp add: pos_recurrent_def)
then have "U y y = 1"
by (simp add: recurrent_iff_U_eq_1)
show "((λx. 1 - gf_U y y x) ⤏ 0) ?L"
using gf_U[of y y] ‹U y y = 1› by (intro tendsto_eq_intros) auto
show "eventually (λx. 1 - gf_U y y x ≠ 0) ?L"
using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
have "eventually (λx. 0 < gf_U' y y x) ?L"
by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: ‹U y y = 1›)
then show "eventually (λx. - gf_U' y y x ≠ 0) ?L"
by eventually_elim simp
show "eventually (λx. DERIV (λx. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
show "eventually (λx. DERIV ((-) 1) x :> - 1) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros)
show "((λx. - 1 / - gf_U' y y x) ⤏ enn2real (1 / U' y y)) ?L"
using ‹recurrent y› by (rule inverse_gf_U'_tendsto)
qed
also have "(∑y∈A n. F x y * enn2real (1 / U' y y)) = (∑y∈A n. enn2real (1 / U' y y))"
proof (intro sum.cong refl)
fix y assume "y ∈ A n"
with ‹A n ⊆ C› have "y ∈ C" by auto
with ‹x ∈ C› have "(x, y) ∈ communicating"
by (rule essential_classD3[OF C])
with ‹y∈C› have "recurrent y" "(y, x) ∈ acc"
using pos[THEN bspec, of y] by (auto simp add: pos_recurrent_def communicating_def)
then have "U x y = 1"
by (rule recurrent_acc)
with F_le_1[of x y] U_le_F[of x y] have "F x y = 1" by simp
then show "F x y * enn2real (1 / U' y y) = enn2real (1 / U' y y)"
by simp
qed
finally have le: "(∑y∈A n. enn2real (1 / U' y y)) ≤ 1"
proof (rule tendsto_le[OF trivial_limit_at_left_real tendsto_const], intro eventually_at_left_1)
fix z :: real assume z: "0 < z" "z < 1"
with ‹x ∈ C› have "norm z < 1"
by auto
then have conv: "⋀x y. convergence_G x y z"
by (simp add: convergence_G_less_1)
have "(∑y∈A n. gf_F x y z / (1 - gf_U y y z)) = (∑y∈A n. gf_G x y z)"
using ‹norm z < 1›
apply (intro sum.cong refl)
apply (subst gf_G_eq_gf_F)
apply assumption
apply (subst gf_G_eq_gf_U(1)[OF conv])
apply auto
done
also have "… = (∑y∈A n. ∑n. p x y n * z^n)"
by (simp add: gf_G_def)
also have "… = (∑i. ∑y∈A n. p x y i *⇩R z^i)"
by (subst suminf_sum[OF convergence_G[OF conv]]) simp
also have "… ≤ (∑i. z^i)"
proof (intro suminf_le summable_sum convergence_G conv summable_geometric allI)
fix l
have "(∑y∈A n. p x y l *⇩R z ^ l) = (∑y∈A n. p x y l) * z ^ l"
by (simp add: sum_distrib_right)
also have "… ≤ z ^ l"
proof (intro mult_left_le_one_le)
have "(∑y∈A n. p x y l) = 𝒫(ω in T x. (x ## ω) !! l ∈ A n)"
unfolding p_def using ‹finite (A n)›
by (subst T.finite_measure_finite_Union[symmetric])
(auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure])
then show "(∑y∈A n. p x y l) ≤ 1"
by simp
qed (insert z, auto simp: sum_nonneg)
finally show "(∑y∈A n. p x y l *⇩R z ^ l) ≤ z ^ l" .
qed fact
also have "… = 1 / (1 - z)"
using sums_unique[OF geometric_sums, OF ‹norm z < 1›] ..
finally have "(∑y∈A n. gf_F x y z / (1 - gf_U y y z)) ≤ 1 / (1 - z)" .
then have "(∑y∈A n. gf_F x y z / (1 - gf_U y y z)) * (1 - z) ≤ 1"
using z by (simp add: field_simps)
then have "(∑y∈A n. gf_F x y z / (1 - gf_U y y z) * (1 - z)) ≤ 1"
by (simp add: sum_distrib_right)
then show "(∑y∈A n. gf_F x y z * ((1 - z) / (1 - gf_U y y z))) ≤ 1"
by simp
qed
from A_n have "emeasure (stat C) (A n) = (∑y∈A n. emeasure (stat C) {y})"
by (intro emeasure_eq_sum_singleton) simp_all
also have "… = (∑y∈A n. inverse (U' y y))"
unfolding stat_def U'_def using A(1)[of n]
apply (intro sum.cong refl)
apply (subst emeasure_point_measure_finite2)
apply (auto simp: divide_ennreal_def Collect_conv_if)
done
also have "… = ennreal (∑y∈A n. enn2real (1 / U' y y))"
apply (subst sum_ennreal[symmetric], simp)
proof (intro sum.cong refl)
fix y assume "y ∈ A n"
with ‹A n ⊆ C› pos have "pos_recurrent y"
by auto
with one_le_integral_t[of y] obtain r where "U' y y = ennreal r" "1 ≤ U' y y" and [simp]: "0 ≤ r"
by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)
then show "inverse (U' y y) = ennreal (enn2real (1 / U' y y))"
by (simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide del: ennreal_1)
qed
also have "… ≤ 1"
using le by simp
finally show "emeasure (stat C) (A n) ≤ 1" .
qed
with A show ?thesis
by simp
qed
lemma emeasure_stat_not_C:
assumes "y ∉ C"
shows "emeasure (stat C) {y} = 0"
unfolding stat_def using ‹y ∉ C›
by (subst emeasure_point_measure_finite2) auto
definition stationary_distribution :: "'s pmf ⇒ bool" where
"stationary_distribution N ⟷ N = bind_pmf N K"
lemma stationary_distributionI:
assumes le: "⋀y. (∫x. pmf (K x) y ∂measure_pmf N) ≤ pmf N y"
shows "stationary_distribution N"
unfolding stationary_distribution_def
proof (rule pmf_eqI antisym)+
fix i
show "pmf (bind_pmf N K) i ≤ pmf N i"
by (simp add: pmf_bind le)
define Ω where "Ω = N ∪ (⋃i∈N. set_pmf (K i))"
then have Ω: "countable Ω"
by (auto intro: countable_set_pmf)
then interpret N: sigma_finite_measure "count_space Ω"
by (rule sigma_finite_measure_count_space_countable)
interpret pN: pair_sigma_finite N "count_space Ω"
by unfold_locales
have measurable_pmf[measurable]: "(λ(x, y). pmf (K x) y) ∈ borel_measurable (N ⨂⇩M count_space Ω)"
unfolding measurable_split_conv
apply (rule measurable_compose_countable'[OF _ measurable_snd])
apply (rule measurable_compose[OF measurable_fst])
apply (simp_all add: Ω)
done
{ assume *: "(∫y. pmf (K y) i ∂N) < pmf N i"
have "0 ≤ (∫y. pmf (K y) i ∂N)"
by (intro integral_nonneg_AE) simp
with * have i: "i ∈ set_pmf N" "i ∈ Ω"
by (auto simp: set_pmf_iff Ω_def not_le[symmetric])
from * have "0 < pmf N i - (∫y. pmf (K y) i ∂N)"
by (simp add: field_simps)
also have "… = (∫t. (pmf N i - (∫y. pmf (K y) i ∂N)) * indicator {i} t ∂count_space Ω)"
by (simp add: i)
also have "… ≤ (∫t. pmf N t - ∫y. pmf (K y) t ∂N ∂count_space Ω)"
using le
by (intro integral_mono integrable_diff)
(auto simp: i pmf_bind[symmetric] integrable_pmf field_simps split: split_indicator)
also have "… = (∫t. pmf N t ∂count_space Ω) - (∫t. ∫y. pmf (K y) t ∂N ∂count_space Ω)"
by (subst Bochner_Integration.integral_diff) (auto intro!: integrable_pmf simp: pmf_bind[symmetric])
also have "(∫t. ∫y. pmf (K y) t ∂N ∂count_space Ω) = (∫y. ∫t. pmf (K y) t ∂count_space Ω ∂N)"
apply (intro pN.Fubini_integral integrable_iff_bounded[THEN iffD2] conjI)
apply (auto simp add: N.nn_integral_fst[symmetric] nn_integral_eq_integral integrable_pmf)
unfolding less_top[symmetric] unfolding infinity_ennreal_def[symmetric]
apply (intro integrableD)
apply (auto intro!: measure_pmf.integrable_const_bound[where B=1]
simp: AE_measure_pmf_iff integral_nonneg_AE integral_pmf)
done
also have "(∫y. ∫t. pmf (K y) t ∂count_space Ω ∂N) = (∫y. 1 ∂N)"
by (intro integral_cong_AE)
(auto simp: AE_measure_pmf_iff integral_pmf Ω_def intro!: measure_pmf.prob_eq_1[THEN iffD2])
finally have False
using measure_pmf.prob_space[of N] by (simp add: integral_pmf field_simps not_le[symmetric]) }
then show "pmf N i ≤ pmf (bind_pmf N K) i"
by (auto simp: pmf_bind not_le[symmetric])
qed
lemma stationary_distribution_iterate:
assumes N: "stationary_distribution N"
shows "ennreal (pmf N y) = (∫⇧+x. p x y n ∂N)"
proof (induct n arbitrary: y)
have [simp]: "⋀x y. ennreal (if x = y then 1 else 0) = indicator {y} x"
by simp
case 0 then show ?case
by (simp add: p_0 pmf.rep_eq measure_pmf.emeasure_eq_measure)
next
case (Suc n) with N show ?case
apply (simp add: nn_integral_eq_integral[symmetric] p_le_1 p_Suc'
measure_pmf.integrable_const_bound[where B=1])
apply (subst nn_integral_bind[symmetric, where B="count_space UNIV"])
apply (auto simp: stationary_distribution_def measure_pmf_bind[symmetric]
simp del: measurable_pmf_measure1)
done
qed
lemma stationary_distribution_iterate':
assumes "stationary_distribution N"
shows "measure N {y} = (∫x. p x y n ∂N)"
using stationary_distribution_iterate[OF assms]
by (subst (asm) nn_integral_eq_integral)
(auto intro!: measure_pmf.integrable_const_bound[where B=1] simp: p_le_1 pmf.rep_eq)
lemma stationary_distributionD:
assumes C: "essential_class C" "countable C"
assumes N: "stationary_distribution N" "N ⊆ C"
shows "∀x∈C. pos_recurrent x" "measure_pmf N = stat C"
proof -
have integrable_K: "⋀f x. integrable N (λs. pmf (K s) (f x))"
by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: pmf_le_1)
have measure_C: "measure N C = 1" and ae_C: "AE x in N. x ∈ C"
using N C measure_pmf.prob_eq_1[of C] by (auto simp: AE_measure_pmf_iff)
have integrable_p: "⋀n y. integrable N (λx. p x y n)"
by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: p_le_1)
{ fix e :: real assume "0 < e"
then have [simp]: "0 ≤ e" by simp
have "∃A⊆C. finite A ∧ 1 - e < measure N A"
proof (rule ccontr)
assume contr: "¬ (∃A ⊆ C. finite A ∧ 1 - e < measure N A)"
from finite_sequence_to_countable_set[OF ‹countable C›] guess F . note F = this
then have *: "(λn. measure N (F n)) ⇢ measure N (⋃i. F i)"
by (intro measure_pmf.finite_Lim_measure_incseq) (auto simp: incseq_Suc_iff)
with F contr have "measure N (⋃i. F i) ≤ 1 - e"
by (intro LIMSEQ_le[OF * tendsto_const]) (auto simp: not_less)
with F ‹0 < e› show False
by (simp add: measure_C)
qed
then obtain A where "A ⊆ C" "finite A" and e: "1 - e < measure N A" by auto
{ fix y n assume "y ∈ C"
from N(1) have "measure N {y} = (∫x. p x y n ∂N)"
by (rule stationary_distribution_iterate')
also have "… ≤ (∫x. p x y n * indicator A x + indicator (C - A) x ∂N)"
using ae_C ‹A ⊆ C›
by (intro integral_mono_AE)
(auto elim!: eventually_mono
intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
integrable_add
split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
also have "… = (∫x. p x y n * indicator A x ∂N) + measure N (C - A)"
using ae_C ‹A ⊆ C›
apply (subst Bochner_Integration.integral_add)
apply (auto elim!: eventually_mono
intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
done
also have "… ≤ (∫x. p x y n * indicator A x ∂N) + e"
using e ‹A ⊆ C› by (simp add: measure_pmf.finite_measure_Diff measure_C)
finally have "measure N {y} ≤ (∫x. p x y n * indicator A x ∂N) + e" .
then have "emeasure N {y} ≤ ennreal (∫x. p x y n * indicator A x ∂N) + e"
by (simp add: measure_pmf.emeasure_eq_measure ennreal_plus[symmetric] del: ennreal_plus)
also have "… = (∫⇧+x. ennreal (p x y n) * indicator A x ∂N) + e"
by (subst nn_integral_eq_integral[symmetric])
(auto intro!: measure_pmf.integrable_const_bound[where B=1]
simp: abs_mult p_le_1 mult_le_one ennreal_indicator ennreal_mult)
finally have "emeasure N {y} ≤ (∫⇧+x. ennreal (p x y n) * indicator A x ∂N) + e" . }
note v_le = this
{ fix y and z :: real assume y: "y ∈ C" and z: "0 < z" "z < 1"
have summable_int_p: "summable (λn. (∫ x. p x y n * indicator A x ∂N) * (1 - z) * z ^ n)"
using ‹y∈C› z ‹A ⊆ C›
by (auto intro!: summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] exI[of _ 0] mult_le_one
measure_pmf.integral_le_const integrable_real_mult_indicator integrable_p AE_I2 p_le_1
simp: abs_mult integral_nonneg_AE)
from y z have sums_y: "(λn. measure N {y} * (1 - z) * z ^ n) sums measure N {y}"
using sums_mult[OF geometric_sums[of z], of "measure N {y} * (1 - z)"] by simp
then have "emeasure N {y} = ennreal (∑n. (measure N {y} * (1 - z)) * z ^ n)"
by (auto simp add: sums_unique[symmetric] measure_pmf.emeasure_eq_measure)
also have "… = (∑n. emeasure N {y} * (1 - z) * z ^ n)"
using z summable_mult[OF summable_geometric[of z], of "measure_pmf.prob N {y} * (1 - z)"]
by (subst suminf_ennreal[symmetric])
(auto simp: measure_pmf.emeasure_eq_measure ennreal_mult[symmetric] ennreal_suminf_neq_top)
also have "… ≤ (∑n. ((∫⇧+x. ennreal (p x y n) * indicator A x ∂N) + e) * (1 - z) * z ^ n)"
using ‹y∈C› z ‹A ⊆ C›
by (intro suminf_le mult_right_mono v_le allI)
(auto simp: measure_pmf.emeasure_eq_measure)
also have "… = (∑n. (∫⇧+x. ennreal (p x y n) * indicator A x ∂N) * (1 - z) * z ^ n) + e"
using ‹0 < e› z sums_mult[OF geometric_sums[of z], of "e * (1 - z)"] ‹0<z› ‹z<1›
by (simp add: distrib_right suminf_add[symmetric] ennreal_suminf_cmult[symmetric]
ennreal_mult[symmetric] suminf_ennreal_eq sums_unique[symmetric]
del: ennreal_suminf_cmult)
also have "… = (∑n. ennreal (1 - z) * ((∫⇧+x. ennreal (p x y n) * indicator A x ∂N) * z ^ n)) + e"
by (simp add: ac_simps)
also have "… = ennreal (1 - z) * (∑n. ((∫⇧+x. ennreal (p x y n) * indicator A x ∂N) * z ^ n)) + e"
using z by (subst ennreal_suminf_cmult) simp_all
also have "(∑n. ((∫⇧+x. ennreal (p x y n) * indicator A x ∂N) * z ^ n)) =
(∑n. (∫⇧+x. ennreal (p x y n * z ^ n) * indicator A x ∂N))"
using z by (simp add: ac_simps nn_integral_cmult[symmetric] ennreal_mult)
also have "… = (∫⇧+x. ennreal (gf_G x y z) * indicator A x ∂N)"
using z
apply (subst nn_integral_suminf[symmetric])
apply (auto simp add: gf_G_def simp del: suminf_ennreal
intro!: ennreal_mult_right_cong suminf_ennreal2 nn_integral_cong)
apply (intro summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] impI)
apply (simp_all add: abs_mult p_le_1 mult_le_one power_le_one split: split_indicator)
done
also have "… = (∫⇧+x. ennreal (gf_F x y z * gf_G y y z) * indicator A x ∂N)"
using z by (intro nn_integral_cong) (simp add: gf_G_eq_gf_F[symmetric])
also have "… = ennreal (gf_G y y z) * (∫⇧+x. ennreal (gf_F x y z) * indicator A x ∂N)"
using z by (subst nn_integral_cmult[symmetric]) (simp_all add: gf_G_nonneg gf_F_nonneg ac_simps ennreal_mult)
also have "… = ennreal (1 / (1 - gf_U y y z)) * (∫⇧+x. ennreal (gf_F x y z) * indicator A x ∂N)"
using z ‹y ∈ C› by (subst gf_G_eq_gf_U) (auto intro!: convergence_G_less_1)
finally have "emeasure N {y} ≤ ennreal ((1 - z) / (1 - gf_U y y z)) * (∫⇧+x. gf_F x y z * indicator A x ∂N) + e"
using z
by (subst (asm) mult.assoc[symmetric])
(simp add: ennreal_indicator[symmetric] ennreal_mult'[symmetric] gf_F_nonneg)
then have "measure N {y} ≤ (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e"
using z
by (subst (asm) nn_integral_eq_integral[OF measure_pmf.integrable_const_bound[where B=1]])
(auto simp: gf_F_nonneg gf_U_le_1 gf_F_le_1 measure_pmf.emeasure_eq_measure mult_le_one
ennreal_mult''[symmetric] ennreal_plus[symmetric]
simp del: ennreal_plus) }
then have "∃A ⊆ C. finite A ∧ (∀y∈C. ∀z. 0 < z ⟶ z < 1 ⟶ measure N {y} ≤ (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e)"
using ‹A ⊆ C› ‹finite A› by auto }
note eps = this
{ fix y A assume "y ∈ C" "finite A" "A ⊆ C"
then have "((λz. ∫x. gf_F x y z * indicator A x ∂N) ⤏ ∫x. F x y * indicator A x ∂N) (at_left 1)"
by (subst (1 2) integral_measure_pmf[of A]) (auto intro!: tendsto_intros gf_F simp: indicator_eq_0_iff) }
note int_gf_F = this
have all_recurrent: "∀y∈C. recurrent y"
proof (rule ccontr)
assume "¬ (∀y∈C. recurrent y)"
then obtain x where "x ∈ C" "¬ recurrent x" by auto
then have transient: "⋀x. x ∈ C ⟹ ¬ recurrent x"
using C by (auto simp: essential_class_def recurrent_iffI_communicating[symmetric] elim!: quotientE)
{ fix y assume "y ∈ C"
with transient have "U y y < 1"
by (metis recurrent_iff_U_eq_1 U_cases)
have "measure N {y} ≤ 0"
proof (rule dense_ge)
fix e :: real assume "0 < e"
from eps[OF this] ‹y ∈ C› obtain A where
A: "finite A" "A ⊆ C" and
le: "⋀z. 0 < z ⟹ z < 1 ⟹ measure N {y} ≤ (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e"
by auto
have "((λz. (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e) ⤏
(1 - 1) / (1 - U y y) * (∫x. F x y * indicator A x ∂N) + e) (at_left (1::real))"
using A ‹U y y < 1› ‹y ∈ C› by (intro tendsto_intros gf_U int_gf_F) auto
then have 1: "((λz. (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e) ⤏ e) (at_left (1::real))"
by simp
with le show "measure N {y} ≤ e"
by (intro tendsto_le[OF trivial_limit_at_left_real _ tendsto_const])
(auto simp: eventually_at_left_1)
qed
then have "measure N {y} = 0"
by (intro antisym measure_nonneg) }
then have "emeasure N C = 0"
by (subst emeasure_countable_singleton) (auto simp: measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE ae_C C)
then show False
using ‹measure N C = 1› by (simp add: measure_pmf.emeasure_eq_measure)
qed
then have "⋀x. x ∈ C ⟹ U x x = 1"
by (metis recurrent_iff_U_eq_1)
{ fix y assume "y ∈ C"
then have "U y y = 1" "recurrent y"
using ‹y ∈ C ⟹ U y y = 1› all_recurrent by auto
have "measure N {y} ≤ enn2real (1 / U' y y)"
proof (rule field_le_epsilon)
fix e :: real assume "0 < e"
from eps[OF ‹0 < e›] ‹y ∈ C› obtain A where
A: "finite A" "A ⊆ C" and
le: "⋀z. 0 < z ⟹ z < 1 ⟹ measure N {y} ≤ (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e"
by auto
let ?L = "at_left (1::real)"
have "((λz. (1 - z) / (1 - gf_U y y z) * (∫x. gf_F x y z * indicator A x ∂N) + e) ⤏
enn2real (1 / U' y y) * (∫x. F x y * indicator A x ∂N) + e) ?L"
proof (intro tendsto_add tendsto_const tendsto_mult int_gf_F,
rule lhopital_left[where f'="λx. - 1" and g'="λz. - gf_U' y y z"])
show "((-) 1 ⤏ 0) ?L" "((λx. 1 - gf_U y y x) ⤏ 0) ?L"
using gf_U[of y y] by (auto intro!: tendsto_eq_intros simp: ‹U y y = 1›)
show "y ∈ C" "finite A" "A ⊆ C" by fact+
show "eventually (λx. 1 - gf_U y y x ≠ 0) ?L"
using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
show "((λx. - 1 / - gf_U' y y x) ⤏ enn2real (1 / U' y y)) ?L"
using ‹recurrent y› by (rule inverse_gf_U'_tendsto)
have "eventually (λx. 0 < gf_U' y y x) ?L"
by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: ‹U y y = 1›)
then show "eventually (λx. - gf_U' y y x ≠ 0) ?L"
by eventually_elim simp
show "eventually (λx. DERIV (λx. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
show "eventually (λx. DERIV ((-) 1) x :> - 1) ?L"
by (auto intro!: eventually_at_left_1 derivative_eq_intros)
qed
then have "measure N {y} ≤ enn2real (1 / U' y y) * (∫x. F x y * indicator A x ∂N) + e"
by (rule tendsto_le[OF trivial_limit_at_left_real _ tendsto_const]) (intro eventually_at_left_1 le)
then have "measure N {y} - e ≤ enn2real (1 / U' y y) * (∫x. F x y * indicator A x ∂N)"
by simp
also have "… ≤ enn2real (1 / U' y y)"
using A
by (intro mult_left_le measure_pmf.integral_le_const measure_pmf.integrable_const_bound[where B=1])
(auto simp: mult_le_one F_le_1 U'_def)
finally show "measure N {y} ≤ enn2real (1 / U' y y) + e"
by simp
qed }
note measure_y_le = this
show pos: "∀y∈C. pos_recurrent y"
proof (rule ccontr)
assume "¬ (∀y∈C. pos_recurrent y)"
then obtain x where x: "x ∈ C" "¬ pos_recurrent x" by auto
{ fix y assume "y ∈ C"
with x have "¬ pos_recurrent y"
using C by (auto simp: essential_class_def pos_recurrent_iffI_communicating[symmetric] elim!: quotientE)
with all_recurrent ‹y ∈ C› have "enn2real (1 / U' y y) = 0"
by (simp add: pos_recurrent_def nn_integral_add)
with measure_y_le[OF ‹y ∈ C›] have "measure N {y} = 0"
by (auto intro!: antisym simp: pos_recurrent_def) }
then have "emeasure N C = 0"
by (subst emeasure_countable_singleton) (auto simp: C ae_C measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE)
then show False
using ‹measure N C = 1› by (simp add: measure_pmf.emeasure_eq_measure)
qed
{ fix A :: "'s set" assume [simp]: "countable A"
have "emeasure N A = (∫⇧+x. emeasure N {x} ∂count_space A)"
by (intro emeasure_countable_singleton) auto
also have "… ≤ (∫⇧+x. emeasure (stat C) {x} ∂count_space A)"
proof (intro nn_integral_mono)
fix y assume "y ∈ space (count_space A)"
show "emeasure N {y} ≤ emeasure (stat C) {y}"
proof cases
assume "y ∈ C"
with pos have "pos_recurrent y"
by auto
with one_le_integral_t[of y] obtain r where r: "U' y y = ennreal r" "1 ≤ U' y y" and [simp]: "0 ≤ r"
by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)
from measure_y_le[OF ‹y ∈ C›]
have "emeasure N {y} ≤ ennreal (enn2real (1 / U' y y))"
by (simp add: measure_pmf.emeasure_eq_measure)
also have "… = emeasure (stat C) {y}"
unfolding stat_def using ‹y ∈ C› r
by (subst emeasure_point_measure_finite2)
(auto simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide ennreal_mult[symmetric]
simp del: ennreal_1)
finally show "emeasure N {y} ≤ emeasure (stat C) {y}"
by simp
next
assume "y ∉ C"
with ae_C have "emeasure N {y} = 0"
by (subst AE_iff_measurable[symmetric, where P="λx. x ≠ y"]) (auto elim!: eventually_mono)
moreover have "emeasure (stat C) {y} = 0"
using emeasure_stat_not_C[OF ‹y ∉ C›] .
ultimately show ?thesis by simp
qed
qed
also have "… = emeasure (stat C) A"
by (intro emeasure_countable_singleton[symmetric]) auto
finally have "emeasure N A ≤ emeasure (stat C) A" . }
note N_le_C = this
from stat_subprob[OF C(1) ‹countable C› pos] N_le_C[OF ‹countable C›] ‹measure N C = 1›
have stat_C_eq_1: "emeasure (stat C) C = 1"
by (auto simp add: measure_pmf.emeasure_eq_measure one_ennreal_def)
moreover have "emeasure (stat C) (UNIV - C) = 0"
by (subst AE_iff_measurable[symmetric, where P="λx. x ∈ C"])
(auto simp: stat_def AE_point_measure sets_point_measure space_point_measure
split: split_indicator cong del: AE_cong)
ultimately have "emeasure (stat C) (space (stat C)) = 1"
using plus_emeasure[of C "stat C" "UNIV - C"] by (simp add: Un_absorb1)
interpret stat: prob_space "stat C"
by standard fact
show "measure_pmf N = stat C"
proof (rule measure_eqI_countable_AE)
show "sets N = UNIV" "sets (stat C) = UNIV"
by auto
show "countable C" "AE x in N. x ∈ C" and ae_stat: "AE x in stat C. x ∈ C"
using C ae_C stat_C_eq_1 by (auto intro!: stat.AE_prob_1 simp: stat.emeasure_eq_measure)
{ assume "∃x. emeasure N {x} ≠ emeasure (stat C) {x}"
then obtain x where [simp]: "emeasure N {x} ≠ emeasure (stat C) {x}" by auto
with N_le_C[of "{x}"] have x: "emeasure N {x} < emeasure (stat C) {x}"
by (auto simp: less_le)
have "1 = emeasure N {x} + emeasure N (C - {x})"
using ae_C
by (subst plus_emeasure) (auto intro!: measure_pmf.emeasure_eq_1_AE)
also have "… < emeasure (stat C) {x} + emeasure (stat C) (C - {x})"
using x N_le_C[of "C - {x}"] C ae_C
by (simp add: stat.emeasure_eq_measure measure_pmf.emeasure_eq_measure
ennreal_plus[symmetric] ennreal_less_iff
del: ennreal_plus)
also have "… = 1"
using ae_stat by (subst plus_emeasure) (auto intro!: stat.emeasure_eq_1_AE)
finally have False by simp }
then show "⋀x. emeasure N {x} = emeasure (stat C) {x}" by auto
qed
qed
lemma measure_point_measure_singleton:
"x ∈ A ⟹ measure (point_measure A X) {x} = enn2real (X x)"
unfolding measure_def by (subst emeasure_point_measure_finite2) auto
lemma stationary_distribution_imp_int_t:
assumes C: "essential_class C" "countable C" "stationary_distribution N" "N ⊆ C"
assumes x: "x ∈ C" shows "U' x x = 1 / ennreal (pmf N x)"
proof -
from stationary_distributionD[OF C]
have "measure_pmf N = stat C" and *: "∀x∈C. pos_recurrent x" by auto
show ?thesis
unfolding ‹measure_pmf N = stat C› pmf.rep_eq stat_def
using *[THEN bspec, OF x] x
apply (simp add: measure_point_measure_singleton)
apply (cases "U' x x")
subgoal for r
by (cases "r = 0")
(simp_all add: divide_ennreal_def inverse_ennreal)
apply simp
done
qed
definition "period_set x = {i. 0 < i ∧ 0 < p x x i }"
definition "period C = (SOME d. ∀x∈C. d = Gcd (period_set x))"
lemma Gcd_period_set_invariant:
assumes c: "(x, y) ∈ communicating"
shows "Gcd (period_set x) = Gcd (period_set y)"
proof -
{ fix x y n assume c: "(x, y) ∈ communicating" "x ≠ y" and n: "n ∈ period_set x"
from c obtain l k where "0 < p x y l" "0 < p y x k"
by (auto simp: communicating_def dest!: accD_pos)
moreover with ‹x ≠ y› have "l ≠ 0 ∧ k ≠ 0"
by (intro notI conjI) (auto simp: p_0)
ultimately have pos: "0 < l" "0 < k" and l: "0 < p x y l" and k: "0 < p y x k"
by auto
from mult_pos_pos[OF k l] prob_reachable_le[of k "k + l" y x y] c
have k_l: "0 < p y y (k + l)"
by simp
then have "Gcd (period_set y) dvd k + l"
using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def)
moreover
from n have "0 < p x x n" "0 < n" by (auto simp: period_set_def)
from mult_pos_pos[OF k this(1)] prob_reachable_le[of k "k + n" y x x] c
have "0 < p y x (k + n)"
by simp
from mult_pos_pos[OF this(1) l] prob_reachable_le[of "k + n" "(k + n) + l" y x y] c
have "0 < p y y (k + n + l)"
by simp
then have "Gcd (period_set y) dvd (k + l) + n"
using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def ac_simps)
ultimately have "Gcd (period_set y) dvd n"
by (metis dvd_add_left_iff add.commute) }
note this[of x y] this[of y x] c
moreover have "(y, x) ∈ communicating"
using c by (simp add: communicating_def)
ultimately show ?thesis
by (auto intro: dvd_antisym Gcd_greatest Gcd_dvd)
qed
lemma period_eq:
assumes "C ∈ UNIV // communicating" "x ∈ C"
shows "period C = Gcd (period_set x)"
unfolding period_def
using assms
by (rule_tac someI2[where a="Gcd (period_set x)"])
(auto intro!: Gcd_period_set_invariant irreducibleD)
definition "aperiodic C ⟷ C ∈ UNIV // communicating ∧ period C = 1"
definition "not_ephemeral C ⟷ C ∈ UNIV // communicating ∧ ¬ (∃x. C = {x} ∧ p x x 1 = 0)"
lemma not_ephemeralD:
assumes C: "not_ephemeral C" "x ∈ C"
shows "∃n>0. 0 < p x x n"
proof cases
assume "∃x. C = {x}"
with ‹x ∈ C› have "C = {x}" by auto
with C p_nonneg[of x x 1] have "0 < p x x 1"
by (auto simp: not_ephemeral_def less_le)
with ‹C = {x}› show ?thesis by auto
next
from C have irr: "C ∈ UNIV // communicating"
by (auto simp: not_ephemeral_def)
assume "¬(∃x. C = {x})"
then have "∀x. C ≠ {x}" by auto
with ‹x ∈ C› obtain y where "y ∈ C" "x ≠ y"
by blast
with irreducibleD[OF irr, of x y] C ‹x ∈ C› have c: "(x, y) ∈ communicating" by auto
with accD_pos[of x y] accD_pos[of y x]
obtain k l where pos: "0 < p x y k" "0 < p y x l"
by (auto simp: communicating_def)
with ‹x ≠ y› have "l ≠ 0"
by (intro notI) (auto simp: p_0)
have "0 < p x y k * p y x (k + l - k)"
using pos by auto
also have "p x y k * p y x (k + l - k) ≤ p x x (k + l)"
using prob_reachable_le[of "k" "k + l" x y x] c by auto
finally show ?thesis
using ‹l ≠ 0› ‹x ∈ C› by (auto intro!: exI[of _ "k + l"])
qed
lemma not_ephemeralD_pos_period:
assumes C: "not_ephemeral C"
shows "0 < period C"
proof -
from C not_empty_irreducible[of C] obtain x where "x ∈ C"
by (auto simp: not_ephemeral_def)
from not_ephemeralD[OF C this]
obtain n where n: "0 < p x x n" "0 < n" by auto
have C': "C ∈ UNIV // communicating"
using C by (auto simp: not_ephemeral_def)
have "period C ≠ 0"
unfolding period_eq [OF C' ‹x ∈ C›]
using n by (auto simp: period_set_def)
then show ?thesis by auto
qed
lemma period_posD:
assumes C: "C ∈ UNIV // communicating" and "0 < period C" "x ∈ C"
shows "∃n>0. 0 < p x x n"
proof -
from ‹0 < period C› have "period C ≠ 0"
by auto
then show ?thesis
unfolding period_eq [OF C ‹x ∈ C›]
unfolding period_set_def by auto
qed
lemma not_ephemeralD_pos_period':
assumes C: "C ∈ UNIV // communicating"
shows "not_ephemeral C ⟷ 0 < period C"
proof (auto dest!: not_ephemeralD_pos_period intro: C)
from C not_empty_irreducible[of C] obtain x where "x ∈ C"
by (auto simp: not_ephemeral_def)
assume "0 < period C"
then show "not_ephemeral C"
apply (auto simp: not_ephemeral_def C)
oops
lemma eventually_periodic:
assumes C: "C ∈ UNIV // communicating" "0 < period C" "x ∈ C"
shows "eventually (λm. 0 < p x x (m * period C)) sequentially"
proof -
from period_posD[OF assms] obtain n where n: "0 < p x x n" "0 < n" by auto
have C': "C ∈ UNIV // communicating"
using C by auto
have "period C ≠ 0"
unfolding period_eq [OF C' ‹x ∈ C›]
using n by (auto simp: period_set_def)
have "eventually (λm. m * Gcd (period_set x) ∈ (period_set x)) sequentially"
proof (rule eventually_mult_Gcd)
show "n > 0" "n ∈ period_set x"
using n by (auto simp add: period_set_def)
fix k l assume "k ∈ period_set x" "l ∈ period_set x"
then have "0 < p x x k * p x x l" "0 < l" "0 < k"
by (auto simp: period_set_def)
moreover have "p x x k * p x x l ≤ p x x (k + l)"
using prob_reachable_le[of k "k + l" x x x] ‹x ∈ C›
by auto
ultimately show "k + l ∈ period_set x"
using ‹0 < l› by (auto simp: period_set_def)
qed
with eventually_ge_at_top[of 1] show "eventually (λm. 0 < p x x (m * period C)) sequentially"
by eventually_elim
(insert ‹period C ≠ 0› period_eq[OF C' ‹x ∈ C›, symmetric], auto simp: period_set_def)
qed
lemma aperiodic_eventually_recurrent:
"aperiodic C ⟷ C ∈ UNIV // communicating ∧ (∀x∈C. eventually (λm. 0 < p x x m) sequentially)"
proof safe
fix x assume "x ∈ C" "aperiodic C"
with eventually_periodic[of C x]
show "eventually (λm. 0 < p x x m) sequentially"
by (auto simp add: aperiodic_def)
next
assume "∀x∈C. eventually (λm. 0 < p x x m) sequentially" and C: "C ∈ UNIV // communicating"
moreover from not_empty_irreducible[OF C] obtain x where "x ∈ C" by auto
ultimately obtain N where "⋀M. M≥N ⟹ 0 < p x x M"
by (auto simp: eventually_sequentially)
then have "{N <..} ⊆ period_set x"
by (auto simp: period_set_def)
from C show "aperiodic C"
unfolding period_eq [OF C ‹x ∈ C›] aperiodic_def
proof
show "Gcd (period_set x) = 1"
proof (rule Gcd_eqI)
from one_dvd show "1 dvd q" for q :: nat .
fix m
assume "⋀q. q ∈ period_set x ⟹ m dvd q"
moreover from ‹{N <..} ⊆ period_set x›
have "{Suc N, Suc (Suc N)} ⊆ period_set x"
by auto
ultimately have "m dvd Suc (Suc N)" and "m dvd Suc N"
by auto
then have "m dvd Suc (Suc N) - Suc N"
by (rule dvd_diff_nat)
then show "is_unit m"
by simp
qed simp
qed
qed (simp add: aperiodic_def)
lemma stationary_distributionD_emeasure:
assumes N: "stationary_distribution N"
shows "emeasure N A = (∫⇧+s. emeasure (K s) A ∂N)"
proof -
have "prob_space (measure_pmf N)"
by intro_locales
then interpret subprob_space "measure_pmf N"
by (rule prob_space_imp_subprob_space)
show ?thesis
unfolding measure_pmf.emeasure_eq_measure
apply (subst N[unfolded stationary_distribution_def])
apply (simp add: measure_pmf_bind)
apply (subst measure_pmf.measure_bind[where N="count_space UNIV"])
apply (rule measurable_compose[OF _ measurable_measure_pmf])
apply (auto intro!: nn_integral_eq_integral[symmetric] measure_pmf.integrable_const_bound[where B=1])
done
qed
lemma communicatingD1:
"C ∈ UNIV // communicating ⟹ (a, b) ∈ communicating ⟹ a ∈ C ⟹ b ∈ C"
by (auto elim!: quotientE) (auto simp add: communicating_def)
lemma communicatingD2:
"C ∈ UNIV // communicating ⟹ (a, b) ∈ communicating ⟹ b ∈ C ⟹ a ∈ C"
by (auto elim!: quotientE) (auto simp add: communicating_def)
lemma acc_iff: "(x, y) ∈ acc ⟷ (∃n. 0 < p x y n)"
by (blast intro: accD_pos accI_pos)
lemma communicating_iff: "(x, y) ∈ communicating ⟷ (∃n. 0 < p x y n) ∧ (∃n. 0 < p y x n)"
by (auto simp add: acc_iff communicating_def)
end
context MC_pair
begin
lemma p_eq_p1_p2:
"p (x1, x2) (y1, y2) n = K1.p x1 y1 n * K2.p x2 y2 n"
unfolding p_def K1.p_def K2.p_def
by (subst prod_eq_prob_T)
(auto intro!: arg_cong2[where f=measure] split: nat.splits simp: Stream_snth)
lemma P_accD:
assumes "((x1, x2), (y1, y2)) ∈ acc"shows "(x1, y1) ∈ K1.acc" "(x2, y2) ∈ K2.acc"
using assms by (auto simp: acc_iff K1.acc_iff K2.acc_iff p_eq_p1_p2 zero_less_mult_iff not_le[of 0, symmetric]
cong: conj_cong)
lemma aperiodicI_pair:
assumes C1: "K1.aperiodic C1" and C2: "K2.aperiodic C2"
shows "aperiodic (C1 × C2)"
unfolding aperiodic_eventually_recurrent
proof safe
from C1[unfolded K1.aperiodic_eventually_recurrent] C2[unfolded K2.aperiodic_eventually_recurrent]
have C1: "C1 ∈ UNIV // K1.communicating" and C2: "C2 ∈ UNIV // K2.communicating" and
ev: "⋀x. x ∈ C1 ⟹ eventually (λm. 0 < K1.p x x m) sequentially" "⋀x. x ∈ C2 ⟹ eventually (λm. 0 < K2.p x x m) sequentially"
by auto
{ fix x1 x2 assume x: "x1 ∈ C1" "x2 ∈ C2"
from ev(1)[OF x(1)] ev(2)[OF x(2)]
show "eventually (λm. 0 < p (x1, x2) (x1, x2) m) sequentially"
by eventually_elim (simp add: p_eq_p1_p2 x) }
{ fix x1 x2 y1 y2
assume acc: "(x1, y1) ∈ K1.acc" "(x2, y2) ∈ K2.acc" "x1 ∈ C1" "y1 ∈ C1" "x2 ∈ C2" "y2 ∈ C2"
then obtain k l where "0 < K1.p x1 y1 l" "0 < K2.p x2 y2 k"
by (auto dest!: K1.accD_pos K2.accD_pos)
with acc ev(1)[of y1] ev(2)[of y2]
have "eventually (λm. 0 < K1.p x1 y1 l * K1.p y1 y1 m ∧ 0 < K2.p x2 y2 k * K2.p y2 y2 m) sequentially"
by (auto elim: eventually_elim2)
then have "eventually (λm. 0 < K1.p x1 y1 (m + l) ∧ 0 < K2.p x2 y2 (m + k)) sequentially"
proof eventually_elim
fix m assume "0 < K1.p x1 y1 l * K1.p y1 y1 m ∧ 0 < K2.p x2 y2 k * K2.p y2 y2 m"
with acc
K1.prob_reachable_le[of l "l + m" x1 y1 y1]
K2.prob_reachable_le[of k "k + m" x2 y2 y2]
show "0 < K1.p x1 y1 (m + l) ∧ 0 < K2.p x2 y2 (m + k)"
by (auto simp add: ac_simps)
qed
then have "eventually (λm. 0 < K1.p x1 y1 m ∧ 0 < K2.p x2 y2 m) sequentially"
unfolding eventually_conj_iff by (subst (asm) (1 2) eventually_sequentially_seg) (auto elim: eventually_elim2)
then obtain N where "0 < K1.p x1 y1 N" "0 < K2.p x2 y2 N"
by (auto simp: eventually_sequentially)
with acc have "0 < p (x1, x2) (y1, y2) N"
by (auto simp add: p_eq_p1_p2)
with acc have "((x1, x2), (y1, y2)) ∈ acc"
by (auto intro!: accI_pos) }
note 1 = this
{ fix x1 x2 y1 y2 assume acc:"((x1, x2), (y1, y2)) ∈ acc"
moreover from acc obtain k where "0 < p (x1, x2) (y1, y2) k" by (auto dest!: accD_pos)
ultimately have "(x1, y1) ∈ K1.acc ∧ (x2, y2) ∈ K2.acc"
by (subst (asm) p_eq_p1_p2)
(auto intro!: K1.accI_pos K2.accI_pos simp: zero_less_mult_iff not_le[of 0, symmetric]) }
note 2 = this
from K1.not_empty_irreducible[OF C1] K2.not_empty_irreducible[OF C2]
obtain x1 x2 where xC: "x1 ∈ C1" "x2 ∈ C2" by auto
show "C1 × C2 ∈ UNIV // communicating"
apply (simp add: quotient_def Image_def)
apply (safe intro!: exI[of _ x1] exI[of _ x2])
proof -
fix y1 y2 assume yC: "y1 ∈ C1" "y2 ∈ C2"
from K1.irreducibleD[OF C1 ‹x1 ∈ C1› ‹y1 ∈ C1›] K2.irreducibleD[OF C2 ‹x2 ∈ C2› ‹y2 ∈ C2›]
show "((x1, x2), (y1, y2)) ∈ communicating"
using 1[of x1 y1 x2 y2] 1[of y1 x1 y2 x2] xC yC
by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
next
fix y1 y2 assume "((x1, x2), (y1, y2)) ∈ communicating"
with 2[of x1 x2 y1 y2] 2[of y1 y2 x1 x2]
have "(x1, y1) ∈ K1.communicating" "(x2, y2) ∈ K2.communicating"
by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
with xC show "y1 ∈ C1" "y2 ∈ C2"
using K1.communicatingD1[OF C1] K2.communicatingD1[OF C2] by auto
qed
qed
lemma stationary_distributionI_pair:
assumes N1: "K1.stationary_distribution N1"
assumes N2: "K2.stationary_distribution N2"
shows "stationary_distribution (pair_pmf N1 N2)"
unfolding stationary_distribution_def
unfolding Kp_def pair_pmf_def
apply (subst N1[unfolded K1.stationary_distribution_def])
apply (subst N2[unfolded K2.stationary_distribution_def])
apply (simp add: bind_assoc_pmf bind_return_pmf)
apply (subst bind_commute_pmf[of N2])
apply simp
done
end
context MC_syntax
begin
lemma stationary_distribution_imp_limit:
assumes C: "aperiodic C" "essential_class C" "countable C" and N: "stationary_distribution N" "N ⊆ C"
assumes [simp]: "y ∈ C"
shows "(λn. ∫x. ¦p y x n - pmf N x¦ ∂count_space C) ⇢ 0"
(is "?L ⇢ 0")
proof -
from ‹essential_class C› have C_comm: "C ∈ UNIV // communicating"
by (simp add: essential_class_def)
define K' where "K' = (λSome x ⇒ map_pmf Some (K x) | None ⇒ map_pmf Some N)"
interpret K2: MC_syntax K' .
interpret KN: MC_pair K K' .
from stationary_distributionD[OF C(2,3) N]
have pos: "⋀x. x ∈ C ⟹ pos_recurrent x" and "measure_pmf N = stat C" by auto
have pos: "⋀x. x ∈ C ⟹ 0 < emeasure N {x}"
using pos unfolding stat_def ‹measure_pmf N = stat C›
by (subst emeasure_point_measure_finite2)
(auto simp: U'_def pos_recurrent_def nn_integral_add ennreal_zero_less_divide less_top)
then have rpos: "⋀x. x ∈ C ⟹ 0 < pmf N x"
by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)
have eq: "⋀x y. (if x = y then 1 else 0) = indicator {y} x" by auto
have intK: "⋀f x. (∫x. (f x :: real) ∂K' (Some x)) = (∫x. f (Some x) ∂K x)"
by (simp add: K'_def integral_distr map_pmf_rep_eq)
{ fix m and x y :: 's
have "K2.p (Some x) (Some y) m = p x y m"
by (induct m arbitrary: x)
(auto intro!: integral_cong simp add: K2.p_Suc' p_Suc' intK K2.p_0 p_0) }
note K_p_eq = this
{ fix n and x :: 's have "K2.p (Some x) None n = 0"
by (induct n arbitrary: x) (auto simp: K2.p_Suc' K2.p_0 intK cong: integral_cong) }
note K_S_None = this
from not_empty_irreducible[OF C_comm] obtain c0 where c0: "c0 ∈ C" by auto
have K2_acc: "⋀x y. (Some x, y) ∈ K2.acc ⟷ (∃z. y = Some z ∧ (x, z) ∈ acc)"
apply (auto simp: K2.acc_iff acc_iff K_p_eq)
apply (case_tac y)
apply (auto simp: K_p_eq K_S_None)
done
have K2_communicating: "⋀c x. c ∈ C ⟹ (Some c, x) ∈ K2.communicating ⟷ (∃c'∈C. x = Some c')"
proof safe
fix x c assume "c ∈ C" "(Some c, x) ∈ K2.communicating"
then show "∃c'∈C. x = Some c'"
by (cases x)
(auto simp: communicating_iff K2.communicating_iff K_p_eq K_S_None intro!: irreducibleD2[OF C_comm ‹c∈C›])
next
fix c c' x assume "c ∈ C" "c' ∈ C"
with irreducibleD[OF C_comm this] show "(Some c, Some c') ∈ K2.communicating"
by (auto simp: K2.communicating_iff communicating_iff K_p_eq)
qed
have "Some ` C ∈ UNIV // K2.communicating"
by (auto simp add: quotient_def Image_def c0 K2_communicating
intro!: exI[of _ "Some c0"])
then have "K2.essential_class (Some ` C)"
by (rule K2.essential_classI)
(auto simp: K2_acc essential_classD2[OF ‹essential_class C›])
have "K2.aperiodic (Some ` C)"
unfolding K2.aperiodic_eventually_recurrent
proof safe
fix x assume "x ∈ C" then show "eventually (λm. 0 < K2.p (Some x) (Some x) m) sequentially"
using ‹aperiodic C› unfolding aperiodic_eventually_recurrent
by (auto elim!: eventually_mono simp: K_p_eq)
qed fact
then have aperiodic: "KN.aperiodic (C × Some ` C)"
by (rule KN.aperiodicI_pair[OF ‹aperiodic C›])
have KN_essential: "KN.essential_class (C × Some ` C)"
proof (rule KN.essential_classI)
show "C × Some ` C ∈ UNIV // KN.communicating"
using aperiodic by (simp add: KN.aperiodic_def)
next
fix x y assume "x ∈ C × Some ` C" "(x, y) ∈ KN.acc"
with KN.P_accD[of "fst x" "snd x" "fst y" "snd y"]
show "y ∈ C × Some ` C"
by (cases x y rule: prod.exhaust[case_product prod.exhaust])
(auto simp: K2_acc essential_classD2[OF ‹essential_class C›])
qed
{ fix n and x y :: 's
have "measure N {y} = 𝒫(ω in K2.T None. (None ## ω) !! (Suc n) = Some y)"
unfolding stationary_distribution_iterate'[OF N(1), of y n]
apply (subst K2.p_def[symmetric])
apply (subst K2.p_Suc')
apply (subst K'_def)
apply (simp add: map_pmf_rep_eq integral_distr K_p_eq)
done
then have "measure N {y} = 𝒫(ω in K2.T None. ω !! n = Some y)"
by simp }
note measure_y_eq = this
define D where "D = {x::'s × 's option. Some (fst x) = snd x}"
have [measurable]:
"⋀P::('s × 's option ⇒ bool). P ∈ measurable (count_space UNIV) (count_space UNIV)"
by simp
{ fix n and x :: 's
have "𝒫(ω in KN.T (y, None). ∃i<n. snd (ω !! n) = Some x ∧ ev_at (HLD D) i ω) =
(∑i<n. 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ev_at (HLD D) i ω))"
by (subst KN.T.finite_measure_finite_Union[symmetric])
(auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure] dest: ev_at_unique)
also have "… = (∑i<n. 𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ev_at (HLD D) i ω))"
proof (intro sum.cong refl)
fix i assume i: "i ∈ {..< n}"
show "𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ev_at (HLD D) i ω) =
𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ev_at (HLD D) i ω)"
apply (subst (1 2) KN.prob_T_split[where n="Suc i"])
apply (simp_all add: ev_at_shift snth_Stream del: stake.simps KN.space_T)
unfolding ev_at_shift snth_Stream
proof (intro Bochner_Integration.integral_cong refl)
fix ω :: "('s × 's option) stream" let ?s = "λω'. stake (Suc i) ω @- ω'"
show "𝒫(ω' in KN.T (ω !! i). snd (?s ω' !! n) = Some x ∧ ev_at (HLD D) i ω) =
𝒫(ω' in KN.T (ω !! i). fst (?s ω' !! n) = x ∧ ev_at (HLD D) i ω)"
proof cases
assume "ev_at (HLD D) i ω"
from ev_at_imp_snth[OF this]
have eq: "snd (ω !! i) = Some (fst (ω !! i))"
by (simp add: D_def HLD_iff)
have "𝒫(ω' in KN.T (ω !! i). fst (ω' !! (n - Suc i)) = x) =
𝒫(ω' in T (fst (ω !! i)). ω' !! (n - Suc i) = x) * 𝒫(ω' in K2.T (snd (ω !! i)). True)"
by (subst KN.prod_eq_prob_T) simp_all
also have "… = p (fst (ω !! i)) x (Suc (n - Suc i))"
using K2.T.prob_space by (simp add: p_def)
also have "… = K2.p (snd (ω !! i)) (Some x) (Suc (n - Suc i))"
by (simp add: K_p_eq eq)
also have "… = 𝒫(ω' in T (fst (ω !! i)). True) * 𝒫(ω' in K2.T (snd (ω !! i)). ω' !! (n - Suc i) = Some x)"
using T.prob_space by (simp add: K2.p_def)
also have "… = 𝒫(ω' in KN.T (ω !! i). snd (ω' !! (n - Suc i)) = Some x)"
by (subst KN.prod_eq_prob_T) simp_all
finally show ?thesis using ‹ev_at (HLD D) i ω› i
by (simp del: stake.simps)
qed simp
qed
qed
also have "… = 𝒫(ω in KN.T (y, None). (∃i<n. fst (ω !! n) = x ∧ ev_at (HLD D) i ω))"
by (subst KN.T.finite_measure_finite_Union[symmetric])
(auto simp add: disjoint_family_on_def dest: ev_at_unique
intro!: arg_cong2[where f=measure])
finally have eq: "𝒫(ω in KN.T (y, None). (∃i<n. snd (ω !! n) = Some x ∧ ev_at (HLD D) i ω)) =
𝒫(ω in KN.T (y, None). (∃i<n. fst (ω !! n) = x ∧ ev_at (HLD D) i ω))" .
have "p y x (Suc n) - measure N {x} = 𝒫(ω in T y. ω !! n = x) - 𝒫(ω in K2.T None. ω !! n = Some x)"
unfolding p_def by (subst measure_y_eq) simp_all
also have "𝒫(ω in T y. ω !! n = x) = 𝒫(ω in T y. ω !! n = x) * 𝒫(ω in K2.T None. True)"
using K2.T.prob_space by simp
also have "… = 𝒫(ω in KN.T (y, None). fst (ω !! n) = x)"
by (subst KN.prod_eq_prob_T) auto
also have "… = 𝒫(ω in KN.T (y, None). (∃i<n. fst (ω !! n) = x ∧ ev_at (HLD D) i ω)) +
𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω))"
by (subst KN.T.finite_measure_Union[symmetric])
(auto intro!: arg_cong2[where f=measure])
also have "𝒫(ω in K2.T None. ω !! n = Some x) = 𝒫(ω in T y. True) * 𝒫(ω in K2.T None. ω !! n = Some x)"
using T.prob_space by simp
also have "… = 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x)"
by (subst KN.prod_eq_prob_T) auto
also have "… = 𝒫(ω in KN.T (y, None). (∃i<n. snd (ω !! n) = Some x ∧ ev_at (HLD D) i ω)) +
𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω))"
by (subst KN.T.finite_measure_Union[symmetric])
(auto intro!: arg_cong2[where f=measure])
finally have "¦ p y x (Suc n) - measure N {x} ¦ =
¦ 𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) -
𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) ¦"
unfolding eq by (simp add: field_simps)
also have "… ≤ ¦ 𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) ¦ +
¦ 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) ¦"
by (rule abs_triangle_ineq4)
also have "… ≤ 𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) +
𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω))"
by simp
finally have "¦ p y x (Suc n) - measure N {x} ¦ ≤ …" . }
note mono = this
{ fix n :: nat
have "(∫⇧+x. ¦ p y x (Suc n) - measure N {x} ¦ ∂count_space C) ≤
(∫⇧+x. ennreal (𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω))) +
ennreal (𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω))) ∂count_space C)"
using mono by (intro nn_integral_mono) (simp add: ennreal_plus[symmetric] del: ennreal_plus)
also have "… = (∫⇧+x. 𝒫(ω in KN.T (y, None). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) ∂count_space C) +
(∫⇧+x. 𝒫(ω in KN.T (y, None). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)) ∂count_space C)"
by (subst nn_integral_add) auto
also have "… = emeasure (KN.T (y, None)) (⋃x∈C. {ω∈space (KN.T (y, None)). fst (ω !! n) = x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)}) +
emeasure (KN.T (y, None)) (⋃x∈C. {ω∈space (KN.T (y, None)). snd (ω !! n) = Some x ∧ ¬ (∃i<n. ev_at (HLD D) i ω)})"
by (subst (1 2) emeasure_UN_countable)
(auto simp add: disjoint_family_on_def KN.T.emeasure_eq_measure C)
also have "… ≤ ennreal (𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω))) + ennreal (𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω)))"
unfolding KN.T.emeasure_eq_measure
by (intro add_mono) (auto intro!: KN.T.finite_measure_mono)
also have "… ≤ 2 * 𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω))"
by (simp add: ennreal_plus[symmetric] del: ennreal_plus)
finally have "?L (Suc n) ≤ 2 * 𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω))"
by (auto intro!: integral_real_bounded simp add: pmf.rep_eq) }
note le_2 = this
have c0_D: "(c0, Some c0) ∈ D"
by (simp add: D_def c0)
let ?N' = "map_pmf Some N"
interpret NP: pair_prob_space N ?N' ..
have pos_recurrent: "∀x∈C × Some ` C. KN.pos_recurrent x"
proof (rule KN.stationary_distributionD(1)[OF KN_essential _ KN.stationary_distributionI_pair[OF N(1)]])
show "K2.stationary_distribution ?N'"
unfolding K2.stationary_distribution_def
by (subst N(1)[unfolded stationary_distribution_def])
(auto intro!: bind_pmf_cong simp: K'_def map_pmf_def bind_assoc_pmf bind_return_pmf)
show "countable (C × Some`C)"
using C by auto
show "set_pmf (pair_pmf N (map_pmf Some N)) ⊆ C × Some ` C"
using ‹N ⊆ C› by auto
qed
from c0_D have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω) ≤ 𝒫(ω in KN.T (y, None). alw (not (HLD {(c0, Some c0)})) ω)"
apply (auto intro!: KN.T.finite_measure_mono)
apply (rule alw_mono, assumption)
apply (auto simp: HLD_iff)
done
also have "… = 0"
apply (rule KN.T.prob_eq_0_AE)
apply (simp add: not_ev_iff[symmetric])
apply (subst KN.AE_T_iff)
apply simp
proof
fix t assume t: "t ∈ KN.Kp (y, None)"
then obtain a b where t_eq: "t = (a, Some b)" "a ∈ K y" "b ∈ N"
unfolding KN.Kp_def by (auto simp: K'_def)
with ‹y ∈ C› have "a ∈ C"
using essential_classD2[OF ‹essential_class C› ‹y ∈ C›] by auto
have "b ∈ C"
using ‹N ⊆ C› ‹b ∈ N› by auto
from pos_recurrent[THEN bspec, of "(c0, Some c0)"]
have recurrent_c0: "KN.recurrent (c0, Some c0)"
by (simp add: KN.pos_recurrent_def c0)
have "C × Some ` C ∈ UNIV // KN.communicating"
using aperiodic by (simp add: KN.aperiodic_def)
then have "((c0, Some c0), t) ∈ KN.communicating"
by (rule KN.irreducibleD) (simp_all add: t_eq c0 ‹b ∈ C› ‹a ∈ C›)
then have "((c0, Some c0), t) ∈ KN.acc"
by (simp add: KN.communicating_def)
then have "KN.U t (c0, Some c0) = 1"
by (rule KN.recurrent_acc(1)[OF recurrent_c0])
then show "AE ω in KN.T t. ev (HLD {(c0, Some c0)}) (t ## ω)"
unfolding KN.U_def by (subst (asm) KN.T.prob_Collect_eq_1) (auto simp add: ev_Stream)
qed
finally have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω) = 0"
by (intro antisym measure_nonneg)
have "(λn. 𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω))) ⇢
measure (KN.T (y, None)) (⋂n. {ω∈space (KN.T (y, None)). ¬ (∃i<n. ev_at (HLD D) i ω)})"
by (rule KN.T.finite_Lim_measure_decseq) (auto simp: decseq_def)
also have "(⋂n. {ω∈space (KN.T (y, None)). ¬ (∃i<n. ev_at (HLD D) i ω)}) =
{ω∈space (KN.T (y, None)). alw (not (HLD D)) ω}"
by (auto simp: not_ev_iff[symmetric] ev_iff_ev_at)
also have "𝒫(ω in KN.T (y, None). alw (not (HLD D)) ω) = 0" by fact
finally have *: "(λn. 2 * 𝒫(ω in KN.T (y, None). ¬ (∃i<n. ev_at (HLD D) i ω))) ⇢ 0"
by (intro tendsto_eq_intros) auto
show ?thesis
apply (rule LIMSEQ_imp_Suc)
apply (rule tendsto_sandwich[OF _ _ tendsto_const *])
using le_2
apply (simp_all add: integral_nonneg_AE)
done
qed
lemma stationary_distribution_imp_p_limit:
assumes "aperiodic C" "essential_class C" and [simp]: "countable C"
assumes N: "stationary_distribution N" "N ⊆ C"
assumes [simp]: "x ∈ C" "y ∈ C"
shows "p x y ⇢ pmf N y"
proof -
define D where "D y n = ¦p x y n - pmf N y¦" for y n
from stationary_distribution_imp_limit[OF assms(1,2,3,4,5,6)]
have INT: "(λn. ∫y. D y n ∂count_space C) ⇢ 0"
unfolding D_def .
{ fix n
have "D y n ≤ (∫z. D y n * indicator {y} z ∂count_space C)"
by simp
also have "… ≤ (∫y. D y n ∂count_space C)"
by (intro integral_mono)
(auto split: split_indicator simp: D_def p_def disjoint_family_on_def
intro!: Bochner_Integration.integrable_diff integrable_pmf T.integrable_measure)
finally have "D y n ≤ (∫y. D y n ∂count_space C)" . }
note * = this
have D_nonneg: "⋀n. 0 ≤ D y n" by (simp add: D_def)
have "D y ⇢ 0"
by (rule tendsto_sandwich[OF _ _ tendsto_const INT])
(auto simp: eventually_sequentially * D_nonneg)
then show ?thesis
using Lim_null[where l="pmf N y" and net=sequentially and f="p x y"]
by (simp add: D_def [abs_def] tendsto_rabs_zero_iff)
qed
end
lemma (in MC_syntax) essential_classI2:
assumes "X ≠ {}"
assumes accI: "⋀x y. x ∈ X ⟹ y ∈ X ⟹ (x, y) ∈ acc"
assumes ED: "⋀x y. x ∈ X ⟹ y ∈ set_pmf (K x) ⟹ y ∈ X"
shows "essential_class X"
proof (rule essential_classI)
{ fix x y assume "(x, y) ∈ acc" "x ∈ X"
then show "y ∈ X"
by induct (auto dest: ED)}
note accD = this
from ‹X ≠ {}› obtain x where "x ∈ X" by auto
from ‹x ∈ X› show "X ∈ UNIV // communicating"
by (auto simp add: quotient_def Image_def communicating_def accI dest: accD intro!: exI[of _ x])
qed
end
Theory Markov_Decision_Process
section ‹Markov Decision Processes›
theory Markov_Decision_Process
imports Discrete_Time_Markov_Chain
begin
definition "some_elem s = (SOME x. x ∈ s)"
lemma some_elem_ne: "s ≠ {} ⟹ some_elem s ∈ s"
unfolding some_elem_def by (auto intro: someI)
subsection ‹Configurations›
text ‹
We want to construct a \emph{non-free} codatatype
‹'s cfg = Cfg (state: 's) (action: 's pmf) (cont: 's ⇒ 's cfg)›.
with the restriction
@{term "state (cont cfg s) = s"}
›
hide_const cont
codatatype 's scheduler = Scheduler (action_sch: "'s pmf") (cont_sch: "'s ⇒ 's scheduler")
lemma equivp_rel_prod: "equivp R ⟹ equivp Q ⟹ equivp (rel_prod R Q)"
by (auto intro!: equivpI prod.rel_symp prod.rel_transp prod.rel_reflp elim: equivpE)
coinductive eq_scheduler :: "'s scheduler ⇒ 's scheduler ⇒ bool"
where
"⋀D. action_sch sc1 = D ⟹ action_sch sc2 = D ⟹
(∀s∈D. eq_scheduler (cont_sch sc1 s) (cont_sch sc2 s)) ⟹ eq_scheduler sc1 sc2"
lemma eq_scheduler_refl[intro]: "eq_scheduler sc sc"
by (coinduction arbitrary: sc) auto
quotient_type 's cfg = "'s × 's scheduler" / "rel_prod (=) eq_scheduler"
proof (intro equivp_rel_prod equivpI reflpI sympI transpI)
show "eq_scheduler sc1 sc2 ⟹ eq_scheduler sc2 sc1" for sc1 sc2 :: "'s scheduler"
by (coinduction arbitrary: sc1 sc2) (auto elim: eq_scheduler.cases)
show "eq_scheduler sc1 sc2 ⟹ eq_scheduler sc2 sc3 ⟹ eq_scheduler sc1 sc3"
for sc1 sc2 sc3 :: "'s scheduler"
by (coinduction arbitrary: sc1 sc2 sc3)
(subst (asm) (1 2) eq_scheduler.simps, auto)
qed auto
lift_definition state :: "'s cfg ⇒ 's" is "fst"
by auto
lift_definition action :: "'s cfg ⇒ 's pmf" is "λ(s, sc). action_sch sc"
by (force elim: eq_scheduler.cases)
lift_definition cont :: "'s cfg ⇒ 's ⇒ 's cfg" is
"λ(s, sc) t. if t ∈ action_sch sc then (t, cont_sch sc t) else
(t, cont_sch sc (some_elem (action_sch sc)))"
apply (simp add: rel_prod_conv split: prod.splits)
apply (subst (asm) eq_scheduler.simps)
apply (auto simp: Let_def set_pmf_not_empty[THEN some_elem_ne])
done
lift_definition Cfg :: "'s ⇒ 's pmf ⇒ ('s ⇒ 's cfg) ⇒ 's cfg" is
"λs D c. (s, Scheduler D (λt. snd (c t)))"
by (auto simp: rel_prod_conv split_beta' eq_scheduler.simps[of "Scheduler _ _"])
lift_definition cfg_corec :: "'s ⇒ ('a ⇒ 's pmf) ⇒ ('a ⇒ 's ⇒ 'a) ⇒ 'a ⇒ 's cfg" is
"λs D C x. (s, corec_scheduler D (λx s. Inr (C x s)) x)" .
lemma state_cont[simp]: "state (cont cfg s) = s"
by transfer (simp split: prod.split)
lemma state_Cfg[simp]: "state (Cfg s d' c') = s"
by transfer simp
lemma action_Cfg[simp]: "action (Cfg s d' c') = d'"
by transfer simp
lemma cont_Cfg[simp]: "t ∈ set_pmf d' ⟹ state (c' t) = t ⟹ cont (Cfg s d' c') t = c' t"
by transfer (auto simp add: rel_prod_conv split: prod.split)
lemma state_cfg_corec[simp]: "state (cfg_corec s d c x) = s"
by transfer auto
lemma action_cfg_corec[simp]: "action (cfg_corec s d c x) = d x"
by transfer auto
lemma cont_cfg_corec[simp]: "t ∈ set_pmf (d x) ⟹ cont (cfg_corec s d c x) t = cfg_corec t d c (c x t)"
by transfer auto
lemma cfg_coinduct[consumes 1, case_names state action cont, coinduct pred]:
"X c d ⟹ (⋀c d. X c d ⟹ state c = state d) ⟹ (⋀c d. X c d ⟹ action c = action d) ⟹
(⋀c d t. X c d ⟹ t ∈ set_pmf (action c) ⟹ X (cont c t) (cont d t)) ⟹ c = d"
proof (transfer, clarsimp)
fix X :: "('a × 'a scheduler) ⇒ ('a × 'a scheduler) ⇒ bool" and B s1 s2 sc1 sc2
assume X: "X (s1, sc1) (s2, sc2)" and "rel_fun cr_cfg (rel_fun cr_cfg (=)) X B"
and 1: "⋀s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2) ⟹ s1 = s2"
and 2: "⋀s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2) ⟹ action_sch sc1 = action_sch sc2"
and 3: "⋀s1 sc1 s2 sc2 t. X (s1, sc1) (s2, sc2) ⟹ t ∈ set_pmf (action_sch sc2) ⟹
X (t, cont_sch sc1 t) (t, cont_sch sc2 t)"
from X show "eq_scheduler sc1 sc2"
by (coinduction arbitrary: s1 s2 sc1 sc2)
(blast dest: 2 3)
qed
coinductive rel_cfg :: "('a ⇒ 'b ⇒ bool) ⇒ 'a cfg ⇒ 'b cfg ⇒ bool" for P :: "'a ⇒ 'b ⇒ bool"
where
"P (state cfg1) (state cfg2) ⟹
rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2) ⟹
rel_cfg P cfg1 cfg2"
lemma rel_cfg_state: "rel_cfg P cfg1 cfg2 ⟹ P (state cfg1) (state cfg2)"
by (auto elim: rel_cfg.cases)
lemma rel_cfg_cont:
"rel_cfg P cfg1 cfg2 ⟹
rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
by (auto elim: rel_cfg.cases)
lemma rel_cfg_action:
assumes P: "rel_cfg P cfg1 cfg2" shows "rel_pmf P (action cfg1) (action cfg2)"
proof (rule pmf.rel_mono_strong)
show "rel_pmf (λs t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
using P by (rule rel_cfg_cont)
qed (auto dest: rel_cfg_state)
lemma rel_cfg_eq: "rel_cfg (=) cfg1 cfg2 ⟷ cfg1 = cfg2"
proof safe
show "rel_cfg (=) cfg1 cfg2 ⟹ cfg1 = cfg2"
proof (coinduction arbitrary: cfg1 cfg2)
case cont
have "action cfg1 = action cfg2"
using ‹rel_cfg (=) cfg1 cfg2› by (auto dest: rel_cfg_action simp: pmf.rel_eq)
then have "rel_pmf (λs t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg1)"
using cont by (auto dest: rel_cfg_cont)
then have "rel_pmf (λs t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t) ∧ s = t) (action cfg1) (action cfg1)"
by (rule pmf.rel_mono_strong) (auto dest: rel_cfg_state)
then have "pred_pmf (λs. rel_cfg (=) (cont cfg1 s) (cont cfg2 s)) (action cfg1)"
unfolding pmf.pred_rel by (rule pmf.rel_mono_strong) (auto simp: eq_onp_def)
with ‹t ∈ action cfg1› show ?case
by (auto simp: pmf.pred_set)
qed (auto dest: rel_cfg_state rel_cfg_action simp: pmf.rel_eq)
show "rel_cfg (=) cfg2 cfg2"
by (coinduction arbitrary: cfg2) (auto intro!: rel_pmf_reflI)
qed
subsection ‹Configuration with Memoryless Scheduler›
definition "memoryless_on f s = cfg_corec s f (λ_ t. t) s"
lemma
shows state_memoryless_on[simp]: "state (memoryless_on f s) = s"
and action_memoryless_on[simp]: "action (memoryless_on f s) = f s"
and cont_memoryless_on[simp]: "t ∈ (f s) ⟹ cont (memoryless_on f s) t = memoryless_on f t"
by (simp_all add: memoryless_on_def)
definition K_cfg :: "'s cfg ⇒ 's cfg pmf" where
"K_cfg cfg = map_pmf (cont cfg) (action cfg)"
lemma set_K_cfg: "set_pmf (K_cfg cfg) = cont cfg ` set_pmf (action cfg)"
by (simp add: K_cfg_def)
lemma nn_integral_K_cfg: "(∫⇧+cfg. f cfg ∂K_cfg cfg) = (∫⇧+s. f (cont cfg s) ∂action cfg)"
by (simp add: K_cfg_def map_pmf_rep_eq nn_integral_distr)
subsection ‹MDP Kernel and Induced Configurations›
locale Markov_Decision_Process =
fixes K :: "'s ⇒ 's pmf set"
assumes K_wf: "⋀s. K s ≠ {}"
begin
definition "E = (SIGMA s:UNIV. ⋃D∈K s. set_pmf D)"
coinductive cfg_onp :: "'s ⇒ 's cfg ⇒ bool" where
"⋀s. state cfg = s ⟹ action cfg ∈ K s ⟹ (⋀t. t ∈ action cfg ⟹ cfg_onp t (cont cfg t)) ⟹
cfg_onp s cfg"
definition "cfg_on s = {cfg. cfg_onp s cfg}"
lemma
shows cfg_onD_action[intro, simp]: "cfg ∈ cfg_on s ⟹ action cfg ∈ K s"
and cfg_onD_cont[intro, simp]: "cfg ∈ cfg_on s ⟹ t ∈ action cfg ⟹ cont cfg t ∈ cfg_on t"
and cfg_onD_state[simp]: "cfg ∈ cfg_on s ⟹ state cfg = s"
and cfg_onI: "state cfg = s ⟹ action cfg ∈ K s ⟹ (⋀t. t ∈ action cfg ⟹ cont cfg t ∈ cfg_on t) ⟹ cfg ∈ cfg_on s"
by (auto simp: cfg_on_def intro: cfg_onp.intros elim: cfg_onp.cases)
lemma cfg_on_coinduct[coinduct set: cfg_on]:
assumes "P s cfg"
assumes "⋀cfg s. P s cfg ⟹ state cfg = s"
assumes "⋀cfg s. P s cfg ⟹ action cfg ∈ K s"
assumes "⋀cfg s t. P s cfg ⟹ t ∈ action cfg ⟹ P t (cont cfg t)"
shows "cfg ∈ cfg_on s"
using assms cfg_onp.coinduct[of P s cfg] by (simp add: cfg_on_def)
lemma memoryless_on_cfg_onI:
assumes "⋀s. f s ∈ K s"
shows "memoryless_on f s ∈ cfg_on s"
by (coinduction arbitrary: s) (auto intro: assms)
lemma cfg_of_cfg_onI:
"D ∈ K s ⟹ (⋀t. t ∈ D ⟹ c t ∈ cfg_on t) ⟹ Cfg s D c ∈ cfg_on s"
by (rule cfg_onI) auto
definition "arb_act s = (SOME D. D ∈ K s)"
lemma arb_actI[simp]: "arb_act s ∈ K s"
by (simp add: arb_act_def some_in_eq K_wf)
lemma cfg_on_not_empty[intro, simp]: "cfg_on s ≠ {}"
by (auto intro: memoryless_on_cfg_onI arb_actI)
sublocale MC: MC_syntax K_cfg .
abbreviation St :: "'s stream measure" where
"St ≡ stream_space (count_space UNIV)"
subsection ‹Trace Space›
definition "T cfg = distr (MC.T cfg) St (smap state)"
sublocale T: prob_space "T cfg" for cfg
by (simp add: T_def MC.T.prob_space_distr)
lemma space_T[simp]: "space (T cfg) = space St"
by (simp add: T_def)
lemma sets_T[simp]: "sets (T cfg) = sets St"
by (simp add: T_def)
lemma measurable_T1[simp]: "measurable (T cfg) N = measurable St N"
by (simp add: T_def)
lemma measurable_T2[simp]: "measurable N (T cfg) = measurable N St"
by (simp add: T_def)
lemma nn_integral_T:
assumes [measurable]: "f ∈ borel_measurable St"
shows "(∫⇧+X. f X ∂T cfg) = (∫⇧+cfg'. (∫⇧+x. f (state cfg' ## x) ∂T cfg') ∂K_cfg cfg)"
by (simp add: T_def MC.nn_integral_T[of _ cfg] nn_integral_distr)
lemma T_eq:
"T cfg = (measure_pmf (K_cfg cfg) ⤜ (λcfg'. distr (T cfg') St (λω. state cfg' ## ω)))"
proof (rule measure_eqI)
fix A assume "A ∈ sets (T cfg)"
then show "emeasure (T cfg) A =
emeasure (measure_pmf (K_cfg cfg) ⤜ (λcfg'. distr (T cfg') St (λω. state cfg' ## ω))) A"
by (subst emeasure_bind[where N=St])
(auto simp: space_subprob_algebra nn_integral_distr nn_integral_indicator[symmetric] nn_integral_T[of _ cfg]
simp del: nn_integral_indicator intro!: prob_space_imp_subprob_space T.prob_space_distr)
qed simp
lemma T_memoryless_on: "T (memoryless_on ct s) = MC_syntax.T ct s"
proof -
interpret ct: MC_syntax ct .
have "T ∘ (memoryless_on ct) = MC_syntax.T ct"
proof (rule ct.T_bisim[symmetric])
fix s show "(T ∘ memoryless_on ct) s =
measure_pmf (ct s) ⤜ (λs. distr ((T ∘ memoryless_on ct) s) St ((##) s))"
by (auto simp add: T_eq[of "memoryless_on ct s"] K_cfg_def map_pmf_rep_eq bind_distr[where K=St]
space_subprob_algebra T.prob_space_distr prob_space_imp_subprob_space
intro!: bind_measure_pmf_cong)
qed (simp_all, intro_locales)
then show ?thesis by (simp add: fun_eq_iff)
qed
lemma nn_integral_T_lfp:
assumes [measurable]: "case_prod g ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
assumes cont_g: "⋀s. sup_continuous (g s)"
assumes int_g: "⋀f cfg. f ∈ borel_measurable (stream_space (count_space UNIV)) ⟹
(∫⇧+ω. g (state cfg) (f ω) ∂T cfg) = g (state cfg) (∫⇧+ω. f ω ∂T cfg)"
shows "(∫⇧+ω. lfp (λf ω. g (shd ω) (f (stl ω))) ω ∂T cfg) =
lfp (λf cfg. ∫⇧+t. g (state t) (f t) ∂K_cfg cfg) cfg"
proof (rule nn_integral_lfp)
show "⋀s. sets (T s) = sets St"
"⋀F. F ∈ borel_measurable St ⟹ (λa. g (shd a) (F (stl a))) ∈ borel_measurable St"
by auto
next
fix s and F :: "'s stream ⇒ ennreal" assume "F ∈ borel_measurable St"
then show "(∫⇧+ a. g (shd a) (F (stl a)) ∂T s) =
(∫⇧+ cfg. g (state cfg) (integral⇧N (T cfg) F) ∂K_cfg s)"
by (rewrite nn_integral_T) (simp_all add: int_g)
qed (auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])
lemma emeasure_Collect_T:
assumes [measurable]: "Measurable.pred St P"
shows "emeasure (T cfg) {x∈space St. P x} =
(∫⇧+cfg'. emeasure (T cfg') {x∈space St. P (state cfg' ## x)} ∂K_cfg cfg)"
using MC.emeasure_Collect_T[of "λx. P (smap state x)" cfg]
by (simp add: nn_integral_distr emeasure_Collect_distr T_def)
definition E_sup :: "'s ⇒ ('s stream ⇒ ennreal) ⇒ ennreal"
where
"E_sup s f = (⨆cfg∈cfg_on s. ∫⇧+x. f x ∂T cfg)"
lemma E_sup_const: "0 ≤ c ⟹ E_sup s (λ_. c) = c"
using T.emeasure_space_1 by (simp add: E_sup_def)
lemma E_sup_mult_right:
assumes [measurable]: "f ∈ borel_measurable St" and [simp]: "0 ≤ c"
shows "E_sup s (λx. c * f x) = c * E_sup s f"
by (simp add: nn_integral_cmult E_sup_def SUP_mult_left_ennreal)
lemma E_sup_mono:
"(⋀ω. f ω ≤ g ω) ⟹ E_sup s f ≤ E_sup s g"
unfolding E_sup_def by (intro SUP_subset_mono order_refl nn_integral_mono)
lemma E_sup_add:
assumes [measurable]: "f ∈ borel_measurable St" "g ∈ borel_measurable St"
shows "E_sup s (λx. f x + g x) ≤ E_sup s f + E_sup s g"
proof -
have "E_sup s (λx. f x + g x) = (⨆cfg∈cfg_on s. (∫⇧+x. f x ∂T cfg) + (∫⇧+x. g x ∂T cfg))"
by (simp add: E_sup_def nn_integral_add)
also have "… ≤ (⨆cfg∈cfg_on s. ∫⇧+x. f x ∂T cfg) + (⨆cfg∈cfg_on s. (∫⇧+x. g x ∂T cfg))"
by (auto simp: SUP_le_iff intro!: add_mono SUP_upper)
finally show ?thesis
by (simp add: E_sup_def)
qed
lemma E_sup_add_left:
assumes [measurable]: "f ∈ borel_measurable St"
shows "E_sup s (λx. f x + c) = E_sup s f + c"
by (simp add: nn_integral_add E_sup_def T.emeasure_space_1[simplified] ennreal_SUP_add_left)
lemma E_sup_add_right:
"f ∈ borel_measurable St ⟹ E_sup s (λx. c + f x) = c + E_sup s f"
using E_sup_add_left[of f s c] by (simp add: add.commute)
lemma E_sup_SUP:
assumes [measurable]: "⋀i. f i ∈ borel_measurable St" and [simp]: "incseq f"
shows "E_sup s (λx. ⨆i. f i x) = (⨆i. E_sup s (f i))"
by (auto simp add: E_sup_def nn_integral_monotone_convergence_SUP intro: SUP_commute)
lemma E_sup_iterate:
assumes [measurable]: "f ∈ borel_measurable St"
shows "E_sup s f = (⨆D∈K s. ∫⇧+ t. E_sup t (λω. f (t ## ω)) ∂measure_pmf D)"
proof -
let ?v = "λt. ∫⇧+x. f (state t ## x) ∂T t"
let ?p = "λt. E_sup t (λω. f (t ## ω))"
have "E_sup s f = (⨆cfg∈cfg_on s. ∫⇧+t. ?v t ∂K_cfg cfg)"
unfolding E_sup_def by (intro SUP_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
also have "… = (⨆D∈K s. ∫⇧+t. ?p t ∂measure_pmf D)"
proof (intro antisym SUP_least)
fix cfg :: "'s cfg" assume cfg: "cfg ∈ cfg_on s"
then show "(∫⇧+ t. ?v t ∂K_cfg cfg) ≤ (SUP D∈K s. ∫⇧+t. ?p t ∂measure_pmf D)"
by (auto simp: E_sup_def nn_integral_K_cfg AE_measure_pmf_iff
intro!: nn_integral_mono_AE SUP_upper2)
next
fix D assume D: "D ∈ K s" show "(∫⇧+t. ?p t ∂D) ≤ (SUP cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg)"
proof cases
assume p_finite: "∀t∈D. ?p t < ∞"
show ?thesis
proof (rule ennreal_le_epsilon)
fix e :: real assume "0 < e"
have "∀t∈D. ∃cfg∈cfg_on t. ?p t ≤ ?v cfg + e"
proof
fix t assume "t ∈ D"
moreover have "(SUP cfg ∈ cfg_on t. ?v cfg) = ?p t"
unfolding E_sup_def by (simp add: cfg_on_def)
ultimately have "(SUP cfg ∈ cfg_on t. ?v cfg) ≠ ∞"
using p_finite by auto
from SUP_approx_ennreal[OF ‹0<e› _ refl this]
show "∃cfg∈cfg_on t. ?p t ≤ ?v cfg + e"
by (auto simp add: E_sup_def intro: less_imp_le)
qed
then obtain cfg' where v_cfg': "⋀t. t ∈ D ⟹ ?p t ≤ ?v (cfg' t) + e" and
cfg_on_cfg': "⋀t. t ∈ D ⟹ cfg' t ∈ cfg_on t"
unfolding Bex_def bchoice_iff by blast
let ?cfg = "Cfg s D cfg'"
have cfg: "K_cfg ?cfg = map_pmf cfg' D"
by (auto simp add: K_cfg_def fun_eq_iff cfg_on_cfg' intro!: map_pmf_cong)
have "(∫⇧+ t. ?p t ∂D) ≤ (∫⇧+t. ?v (cfg' t) + e ∂D)"
by (intro nn_integral_mono_AE) (simp add: v_cfg' AE_measure_pmf_iff)
also have "… = (∫⇧+t. ?v (cfg' t) ∂D) + e"
using ‹0 < e› measure_pmf.emeasure_space_1[of D]
by (subst nn_integral_add) (auto intro: cfg_on_cfg' )
also have "(∫⇧+t. ?v (cfg' t) ∂D) = (∫⇧+t. ?v t ∂K_cfg ?cfg)"
by (simp add: cfg map_pmf_rep_eq nn_integral_distr)
also have "… ≤ (SUP cfg∈cfg_on s. (∫⇧+t. ?v t ∂K_cfg cfg))"
by (auto intro!: SUP_upper intro!: cfg_of_cfg_onI D cfg_on_cfg')
finally show "(∫⇧+ t. ?p t ∂D) ≤ (SUP cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg) + e"
by (blast intro: add_mono)
qed
next
assume "¬ (∀t∈D. ?p t < ∞)"
then obtain t where "t ∈ D" "?p t = ∞"
by (auto simp: not_less top_unique)
then have "∞ = pmf (D) t * ?p t"
by (auto simp: ennreal_mult_top set_pmf_iff)
also have "… = (SUP cfg ∈ cfg_on t. pmf (D) t * ?v cfg)"
unfolding E_sup_def
by (auto simp: SUP_mult_left_ennreal[symmetric])
also have "… ≤ (SUP cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg)"
unfolding E_sup_def
proof (intro SUP_least SUP_upper2)
fix cfg :: "'s cfg" assume cfg: "cfg ∈ cfg_on t"
let ?cfg = "Cfg s D ((memoryless_on arb_act) (t := cfg))"
have C: "K_cfg ?cfg = map_pmf ((memoryless_on arb_act) (t := cfg)) D"
by (auto simp add: K_cfg_def fun_eq_iff intro!: map_pmf_cong simp: cfg)
show "?cfg ∈ cfg_on s"
by (auto intro!: cfg_of_cfg_onI D cfg memoryless_on_cfg_onI)
have "ennreal (pmf (D) t) * (∫⇧+ x. f (state cfg ## x) ∂T cfg) =
(∫⇧+t'. (∫⇧+ x. f (state cfg ## x) ∂T cfg) * indicator {t} t' ∂D)"
by (auto simp add: max_def emeasure_pmf_single intro: mult_ac)
also have "… = (∫⇧+cfg. ?v cfg * indicator {t} (state cfg) ∂K_cfg ?cfg)"
unfolding C using cfg
by (auto simp add: nn_integral_distr map_pmf_rep_eq split: split_indicator
simp del: nn_integral_indicator_singleton
intro!: nn_integral_cong)
also have "… ≤ (∫⇧+cfg. ?v cfg ∂K_cfg ?cfg)"
by (auto intro!: nn_integral_mono split: split_indicator)
finally show "ennreal (pmf (D) t) * (∫⇧+ x. f (state cfg ## x) ∂T cfg)
≤ (∫⇧+ t. ∫⇧+ x. f (state t ## x) ∂T t ∂K_cfg ?cfg)" .
qed
finally show ?thesis
by (simp add: top_unique del: Sup_eq_top_iff SUP_eq_top_iff)
qed
qed
finally show ?thesis .
qed
lemma E_sup_bot: "E_sup s ⊥ = 0"
by (auto simp add: E_sup_def bot_ennreal)
lemma E_sup_lfp:
fixes g
defines "l ≡ λf ω. g (shd ω) (f (stl ω))"
assumes measurable_g[measurable]: "case_prod g ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
assumes cont_g: "⋀s. sup_continuous (g s)"
assumes int_g: "⋀f cfg. f ∈ borel_measurable St ⟹
(∫⇧+ ω. g (state cfg) (f ω) ∂T cfg) = g (state cfg) (integral⇧N (T cfg) f)"
shows "(λs. E_sup s (lfp l)) = lfp (λf s. ⨆D∈K s. ∫⇧+t. g t (f t) ∂measure_pmf D)"
proof (rule lfp_transfer_bounded[where α="λF s. E_sup s F" and f=l and P="λf. f ∈ borel_measurable St"])
show "sup_continuous (λf s. ⨆x∈K s. ∫⇧+ t. g t (f t) ∂measure_pmf x)"
using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros)
show "sup_continuous l"
using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros simp: l_def)
show "⋀F. (λs. E_sup s ⊥) ≤ (λs. ⨆D∈K s. ∫⇧+ t. g t (F t) ∂measure_pmf D)"
using K_wf by (auto simp: E_sup_bot le_fun_def intro: SUP_upper2 )
next
fix f :: "'s stream ⇒ ennreal" assume f: "f ∈ borel_measurable St"
moreover
have "E_sup s (λω. g s (f ω)) = g s (E_sup s f)" for s
unfolding E_sup_def using int_g[OF f]
by (subst SUP_sup_continuous_ennreal[OF cont_g, symmetric])
(auto intro!: SUP_cong simp del: cfg_onD_state dest: cfg_onD_state[symmetric])
ultimately show "(λs. E_sup s (l f)) = (λs. ⨆D∈K s. ∫⇧+ t. g t (E_sup t f) ∂measure_pmf D)"
by (subst E_sup_iterate) (auto simp: l_def int_g fun_eq_iff intro!: SUP_cong nn_integral_cong)
qed (auto simp: bot_fun_def l_def SUP_apply[abs_def] E_sup_SUP)
definition "P_sup s P = (⨆cfg∈cfg_on s. emeasure (T cfg) {x∈space St. P x})"
lemma P_sup_eq_E_sup:
assumes [measurable]: "Measurable.pred St P"
shows "P_sup s P = E_sup s (indicator {x∈space St. P x})"
by (auto simp add: P_sup_def E_sup_def intro!: SUP_cong nn_integral_cong)
lemma P_sup_True[simp]: "P_sup t (λω. True) = 1"
using T.emeasure_space_1
by (auto simp add: P_sup_def SUP_constant)
lemma P_sup_False[simp]: "P_sup t (λω. False) = 0"
by (auto simp add: P_sup_def SUP_constant)
lemma P_sup_SUP:
fixes P :: "nat ⇒ 's stream ⇒ bool"
assumes "mono P" and P[measurable]: "⋀i. Measurable.pred St (P i)"
shows "P_sup s (λx. ∃i. P i x) = (⨆i. P_sup s (P i))"
proof -
have "P_sup s (λx. ⨆i. P i x) = (⨆cfg∈cfg_on s. emeasure (T cfg) (⋃i. {x∈space St. P i x}))"
by (auto simp: P_sup_def intro!: SUP_cong arg_cong2[where f=emeasure])
also have "… = (⨆cfg∈cfg_on s. ⨆i. emeasure (T cfg) {x∈space St. P i x})"
using ‹mono P› by (auto intro!: SUP_cong SUP_emeasure_incseq[symmetric] simp: mono_def le_fun_def)
also have "… = (⨆i. P_sup s (P i))"
by (subst SUP_commute) (simp add: P_sup_def)
finally show ?thesis
by simp
qed
lemma P_sup_lfp:
assumes Q: "sup_continuous Q"
assumes f: "f ∈ measurable St M"
assumes Q_m: "⋀P. Measurable.pred M P ⟹ Measurable.pred M (Q P)"
shows "P_sup s (λx. lfp Q (f x)) = (⨆i. P_sup s (λx. (Q ^^ i) ⊥ (f x)))"
unfolding sup_continuous_lfp[OF Q]
apply simp
proof (rule P_sup_SUP)
fix i show "Measurable.pred St (λx. (Q ^^ i) ⊥ (f x))"
apply (intro measurable_compose[OF f])
by (induct i) (auto intro!: Q_m)
qed (intro mono_funpow sup_continuous_mono[OF Q] mono_compose[where f=f])
lemma P_sup_iterate:
assumes [measurable]: "Measurable.pred St P"
shows "P_sup s P = (⨆D∈K s. ∫⇧+ t. P_sup t (λω. P (t ## ω)) ∂measure_pmf D)"
proof -
have [simp]: "⋀x s. indicator {x ∈ space St. P x} (x ## s) = indicator {s ∈ space St. P (x ## s)} s"
by (auto simp: space_stream_space split: split_indicator)
show ?thesis
using E_sup_iterate[of "indicator {x∈space St. P x}" s] by (auto simp: P_sup_eq_E_sup)
qed
definition "E_inf s f = (⨅cfg∈cfg_on s. ∫⇧+x. f x ∂T cfg)"
lemma E_inf_const: "0 ≤ c ⟹ E_inf s (λ_. c) = c"
using T.emeasure_space_1 by (simp add: E_inf_def)
lemma E_inf_mono:
"(⋀ω. f ω ≤ g ω) ⟹ E_inf s f ≤ E_inf s g"
unfolding E_inf_def by (intro INF_superset_mono order_refl nn_integral_mono)
lemma E_inf_iterate:
assumes [measurable]: "f ∈ borel_measurable St"
shows "E_inf s f = (⨅D∈K s. ∫⇧+ t. E_inf t (λω. f (t ## ω)) ∂measure_pmf D)"
proof -
let ?v = "λt. ∫⇧+x. f (state t ## x) ∂T t"
let ?p = "λt. E_inf t (λω. f (t ## ω))"
have "E_inf s f = (⨅cfg∈cfg_on s. ∫⇧+t. ?v t ∂K_cfg cfg)"
unfolding E_inf_def by (intro INF_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
also have "… = (⨅D∈K s. ∫⇧+t. ?p t ∂measure_pmf D)"
proof (intro antisym INF_greatest)
fix cfg :: "'s cfg" assume cfg: "cfg ∈ cfg_on s"
then show "(INF D∈K s. ∫⇧+t. ?p t ∂measure_pmf D) ≤ (∫⇧+ t. ?v t ∂K_cfg cfg)"
by (auto simp add: E_inf_def nn_integral_K_cfg AE_measure_pmf_iff intro!: nn_integral_mono_AE INF_lower2)
next
fix D assume D: "D ∈ K s" show "(INF cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg) ≤ (∫⇧+t. ?p t ∂D)"
proof (rule ennreal_le_epsilon)
fix e :: real assume "0 < e"
have "∀t∈D. ∃cfg∈cfg_on t. ?v cfg ≤ ?p t + e"
proof
fix t assume "t ∈ D"
show "∃cfg∈cfg_on t. ?v cfg ≤ ?p t + e"
proof cases
assume "?p t = ∞" with cfg_on_not_empty[of t] show ?thesis
by (auto simp: top_add simp del: cfg_on_not_empty)
next
assume p_finite: "?p t ≠ ∞"
note ‹t ∈ D›
moreover have "(INF cfg ∈ cfg_on t. ?v cfg) = ?p t"
unfolding E_inf_def by (simp add: cfg_on_def)
ultimately have "(INF cfg ∈ cfg_on t. ?v cfg) ≠ ∞"
using p_finite by auto
from INF_approx_ennreal[OF ‹0 < e› refl this]
show "∃cfg∈cfg_on t. ?v cfg ≤ ?p t + e"
by (auto simp: E_inf_def intro: less_imp_le)
qed
qed
then obtain cfg' where v_cfg': "⋀t. t ∈ D ⟹ ?v (cfg' t) ≤ ?p t + e" and
cfg_on_cfg': "⋀t. t ∈ D ⟹ cfg' t ∈ cfg_on t"
unfolding Bex_def bchoice_iff by blast
let ?cfg = "Cfg s D cfg'"
have cfg: "K_cfg ?cfg = map_pmf cfg' D"
by (auto simp add: K_cfg_def cfg_on_cfg' intro!: map_pmf_cong)
have "?cfg ∈ cfg_on s"
by (auto intro: D cfg_on_cfg' cfg_of_cfg_onI)
then have "(INF cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg) ≤ (∫⇧+ t. ?p t + e ∂D)"
by (rule INF_lower2) (auto simp: cfg map_pmf_rep_eq nn_integral_distr v_cfg' AE_measure_pmf_iff intro!: nn_integral_mono_AE)
also have "… = (∫⇧+ t. ?p t ∂D) + e"
using ‹0 < e› by (simp add: nn_integral_add measure_pmf.emeasure_space_1[simplified])
finally show "(INF cfg ∈ cfg_on s. ∫⇧+ t. ?v t ∂K_cfg cfg) ≤ (∫⇧+ t. ?p t ∂D) + e" .
qed
qed
finally show ?thesis .
qed
lemma emeasure_T_const[simp]: "emeasure (T s) (space St) = 1"
using T.emeasure_space_1[of s] by simp
lemma E_inf_greatest:
"(⋀cfg. cfg ∈ cfg_on s ⟹ x ≤ (∫⇧+x. f x ∂T cfg)) ⟹ x ≤ E_inf s f"
unfolding E_inf_def by (rule INF_greatest)
lemma E_inf_lower2:
"cfg ∈ cfg_on s ⟹ (∫⇧+x. f x ∂T cfg) ≤ x ⟹ E_inf s f ≤ x"
unfolding E_inf_def by (rule INF_lower2)
text ‹
Maybe the following statement can be generalized to infinite @{term "K s"}.
›
lemma E_inf_lfp:
fixes g
defines "l ≡ λf ω. g (shd ω) (f (stl ω))"
assumes measurable_g[measurable]: "case_prod g ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
assumes cont_g: "⋀s. sup_continuous (g s)"
assumes int_g: "⋀f cfg. f ∈ borel_measurable St ⟹
(∫⇧+ ω. g (state cfg) (f ω) ∂T cfg) = g (state cfg) (integral⇧N (T cfg) f)"
assumes K_finite: "⋀s. finite (K s)"
shows "(λs. E_inf s (lfp l)) = lfp (λf s. ⨅D∈K s. ∫⇧+t. g t (f t) ∂measure_pmf D)"
proof (rule antisym)
let ?F = "λF s. ⨅D∈K s. ∫⇧+ t. g t (F t) ∂measure_pmf D"
let ?I = "λD. (∫⇧+t. g t (lfp ?F t) ∂measure_pmf D)"
have mono_F: "mono ?F"
using sup_continuous_mono[OF cont_g]
by (force intro!: INF_mono nn_integral_mono monoI simp: mono_def le_fun_def)
define ct where "ct s = (SOME D. D ∈ K s ∧ (lfp ?F s = ?I D))" for s
{ fix s
have "finite (?I ` K s)"
by (auto intro: K_finite)
then obtain D where "D ∈ K s" "?I D = Min (?I ` K s)"
by (auto simp: K_wf dest!: Min_in)
note this(2)
also have "… = (INF D ∈ K s. ?I D)"
using K_wf by (subst Min_Inf) (auto intro: K_finite)
also have "… = lfp ?F s"
by (rewrite in "_ = ⌑" lfp_unfold[OF mono_F]) auto
finally have "∃D. D ∈ K s ∧ (lfp ?F s = ?I D)"
using ‹D ∈ K s› by auto
then have "ct s ∈ K s ∧ (lfp ?F s = ?I (ct s))"
unfolding ct_def by (rule someI_ex)
then have "ct s ∈ K s" "lfp ?F s = ?I (ct s)"
by auto }
note ct = this
then have ct_cfg_on[simp]: "⋀s. memoryless_on ct s ∈ cfg_on s"
by (intro memoryless_on_cfg_onI) simp
then show "(λs. E_inf s (lfp l)) ≤ lfp ?F"
proof (intro le_funI, rule E_inf_lower2)
fix s
define P where "P f cfg = ∫⇧+ t. g (state t) (f t) ∂K_cfg cfg" for f cfg
have "integral⇧N (T (memoryless_on ct s)) (lfp l) = lfp P (memoryless_on ct s)"
unfolding P_def l_def using measurable_g cont_g int_g by (rule nn_integral_T_lfp)
also have "… = (SUP i. (P ^^ i) ⊥) (memoryless_on ct s)"
by (rewrite sup_continuous_lfp)
(auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose] simp: P_def)
also have "… = (SUP i. (P ^^ i) ⊥ (memoryless_on ct s))"
by (simp add: image_comp)
also have "… ≤ lfp ?F s"
proof (rule SUP_least)
fix i show "(P ^^ i) ⊥ (memoryless_on ct s) ≤ lfp ?F s"
proof (induction i arbitrary: s)
case 0 then show ?case
by simp
next
case (Suc n)
have "(P ^^ Suc n) ⊥ (memoryless_on ct s) =
(∫⇧+ t. g t ((P ^^ n) ⊥ (memoryless_on ct t)) ∂ct s)"
by (auto simp add: P_def K_cfg_def AE_measure_pmf_iff intro!: nn_integral_cong_AE)
also have "… ≤ (∫⇧+ t. g t (lfp ?F t) ∂ct s)"
by (intro nn_integral_mono sup_continuous_mono[OF cont_g, THEN monoD] Suc)
also have "… = lfp ?F s"
by (rule ct(2) [symmetric])
finally show ?case .
qed
qed
finally show "integral⇧N (T (memoryless_on ct s)) (lfp l) ≤ lfp ?F s" .
qed
have cont_l: "sup_continuous l"
by (auto simp: l_def intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])
show "lfp ?F ≤ (λs. E_inf s (lfp l))"
proof (intro lfp_lowerbound le_funI)
fix s show "(⨅x∈K s. ∫⇧+ t. g t (E_inf t (lfp l)) ∂measure_pmf x) ≤ E_inf s (lfp l)"
proof (rewrite in "_ ≤ ⌑" E_inf_iterate)
show l: "lfp l ∈ borel_measurable St"
using cont_l by (rule borel_measurable_lfp) (simp add: l_def)
show "(⨅D∈K s. ∫⇧+ t. g t (E_inf t (lfp l)) ∂measure_pmf D) ≤
(⨅D∈K s. ∫⇧+ t. E_inf t (λω. lfp l (t ## ω)) ∂measure_pmf D)"
proof (rule INF_mono nn_integral_mono bexI)+
fix t D assume "D ∈ K s"
{ fix cfg assume "cfg ∈ cfg_on t"
have "(∫⇧+ ω. g (state cfg) (lfp l ω) ∂T cfg) = g (state cfg) (∫⇧+ ω. (lfp l ω) ∂T cfg)"
using l by (rule int_g)
with ‹cfg ∈ cfg_on t› have *: "(∫⇧+ ω. g t (lfp l ω) ∂T cfg) = g t (∫⇧+ ω. (lfp l ω) ∂T cfg)"
by simp }
then
have *: "g t (⨅cfg∈cfg_on t. integral⇧N (T cfg) (lfp l)) ≤ (⨅cfg∈cfg_on t. ∫⇧+ ω. g t (lfp l ω) ∂T cfg)"
apply simp
apply (rule INF_greatest)
apply (rule sup_continuous_mono[OF cont_g, THEN monoD])
apply (rule INF_lower)
apply assumption
done
show "g t (E_inf t (lfp l)) ≤ E_inf t (λω. lfp l (t ## ω))"
apply (rewrite in "_ ≤ ⌑" lfp_unfold[OF sup_continuous_mono[OF cont_l]])
apply (rewrite in "_ ≤ ⌑" l_def)
apply (simp add: E_inf_def *)
done
qed
qed
qed
qed
definition "P_inf s P = (⨅cfg∈cfg_on s. emeasure (T cfg) {x∈space St. P x})"
lemma P_inf_eq_E_inf:
assumes [measurable]: "Measurable.pred St P"
shows "P_inf s P = E_inf s (indicator {x∈space St. P x})"
by (auto simp add: P_inf_def E_inf_def intro!: SUP_cong nn_integral_cong)
lemma P_inf_True[simp]: "P_inf t (λω. True) = 1"
using T.emeasure_space_1
by (auto simp add: P_inf_def SUP_constant)
lemma P_inf_False[simp]: "P_inf t (λω. False) = 0"
by (auto simp add: P_inf_def SUP_constant)
lemma P_inf_INF:
fixes P :: "nat ⇒ 's stream ⇒ bool"
assumes "decseq P" and P[measurable]: "⋀i. Measurable.pred St (P i)"
shows "P_inf s (λx. ∀i. P i x) = (⨅i. P_inf s (P i))"
proof -
have "P_inf s (λx. ⨅i. P i x) = (⨅cfg∈cfg_on s. emeasure (T cfg) (⋂i. {x∈space St. P i x}))"
by (auto simp: P_inf_def intro!: INF_cong arg_cong2[where f=emeasure])
also have "… = (⨅cfg∈cfg_on s. ⨅i. emeasure (T cfg) {x∈space St. P i x})"
using ‹decseq P› by (auto intro!: INF_cong INF_emeasure_decseq[symmetric] simp: decseq_def le_fun_def)
also have "… = (⨅i. P_inf s (P i))"
by (subst INF_commute) (simp add: P_inf_def)
finally show ?thesis
by simp
qed
lemma P_inf_gfp:
assumes Q: "inf_continuous Q"
assumes f: "f ∈ measurable St M"
assumes Q_m: "⋀P. Measurable.pred M P ⟹ Measurable.pred M (Q P)"
shows "P_inf s (λx. gfp Q (f x)) = (⨅i. P_inf s (λx. (Q ^^ i) ⊤ (f x)))"
unfolding inf_continuous_gfp[OF Q]
apply simp
proof (rule P_inf_INF)
fix i show "Measurable.pred St (λx. (Q ^^ i) ⊤ (f x))"
apply (intro measurable_compose[OF f])
by (induct i) (auto intro!: Q_m)
next
show "decseq (λi x. (Q ^^ i) ⊤ (f x))"
using inf_continuous_mono[OF Q, THEN funpow_increasing[rotated]]
unfolding decseq_def le_fun_def by auto
qed
lemma P_inf_iterate:
assumes [measurable]: "Measurable.pred St P"
shows "P_inf s P = (⨅D∈K s. ∫⇧+ t. P_inf t (λω. P (t ## ω)) ∂measure_pmf D)"
proof -
have [simp]: "⋀x s. indicator {x ∈ space St. P x} (x ## s) = indicator {s ∈ space St. P (x ## s)} s"
by (auto simp: space_stream_space split: split_indicator)
show ?thesis
using E_inf_iterate[of "indicator {x∈space St. P x}" s] by (auto simp: P_inf_eq_E_inf)
qed
end
subsection ‹Finite MDPs›
locale Finite_Markov_Decision_Process = Markov_Decision_Process K for K :: "'s ⇒ 's pmf set" +
fixes S :: "'s set"
assumes S_not_empty: "S ≠ {}"
assumes S_finite: "finite S"
assumes K_closed: "⋀s. s ∈ S ⟹ (⋃D∈K s. set_pmf D) ⊆ S"
assumes K_finite: "⋀s. s ∈ S ⟹ finite (K s)"
begin
lemma action_closed: "s ∈ S ⟹ cfg ∈ cfg_on s ⟹ t ∈ action cfg ⟹ t ∈ S"
using cfg_onD_action[of cfg s] K_closed[of s] by auto
lemma set_pmf_closed: "s ∈ S ⟹ D ∈ K s ⟹ t ∈ D ⟹ t ∈ S"
using K_closed by auto
lemma Pi_closed: "ct ∈ Pi S K ⟹ s ∈ S ⟹ t ∈ ct s ⟹ t ∈ S"
using set_pmf_closed by auto
lemma E_closed: "s ∈ S ⟹ (s, t) ∈ E ⟹ t ∈ S"
using K_closed by (auto simp: E_def)
lemma set_pmf_finite: "s ∈ S ⟹ D ∈ K s ⟹ finite D"
using K_closed by (intro finite_subset[OF _ S_finite]) auto
definition "valid_cfg = (⋃s∈S. cfg_on s)"
lemma valid_cfgI: "s ∈ S ⟹ cfg ∈ cfg_on s ⟹ cfg ∈ valid_cfg"
by (auto simp: valid_cfg_def)
lemma valid_cfgD: "cfg ∈ valid_cfg ⟹ cfg ∈ cfg_on (state cfg)"
by (auto simp: valid_cfg_def)
lemma
shows valid_cfg_state_in_S: "cfg ∈ valid_cfg ⟹ state cfg ∈ S"
and valid_cfg_action: "cfg ∈ valid_cfg ⟹ s ∈ action cfg ⟹ s ∈ S"
and valid_cfg_cont: "cfg ∈ valid_cfg ⟹ s ∈ action cfg ⟹ cont cfg s ∈ valid_cfg"
by (auto simp: valid_cfg_def intro!: bexI[of _ s] intro: action_closed)
lemma valid_K_cfg[intro]: "cfg ∈ valid_cfg ⟹ cfg' ∈ K_cfg cfg ⟹ cfg' ∈ valid_cfg"
by (auto simp add: K_cfg_def valid_cfg_cont)
definition "simple ct = memoryless_on (λs. if s ∈ S then ct s else arb_act s)"
lemma simple_cfg_on[simp]: "ct ∈ Pi S K ⟹ simple ct s ∈ cfg_on s"
by (auto simp: simple_def intro!: memoryless_on_cfg_onI)
lemma simple_valid_cfg[simp]: "ct ∈ Pi S K ⟹ s ∈ S ⟹ simple ct s ∈ valid_cfg"
by (auto intro: valid_cfgI)
lemma cont_simple[simp]: "s ∈ S ⟹ t ∈ set_pmf (ct s) ⟹ cont (simple ct s) t = simple ct t"
by (simp add: simple_def)
lemma state_simple[simp]: "state (simple ct s) = s"
by (simp add: simple_def)
lemma action_simple[simp]: "s ∈ S ⟹ action (simple ct s) = ct s"
by (simp add: simple_def)
lemma simple_valid_cfg_iff: "ct ∈ Pi S K ⟹ simple ct s ∈ valid_cfg ⟷ s ∈ S"
using cfg_onD_state[of "simple ct s"] by (auto simp add: valid_cfg_def intro!: bexI[of _ s])
end
end
Theory MDP_Reachability_Problem
theory MDP_Reachability_Problem
imports Markov_Decision_Process
begin
inductive_set directed_towards :: "'a set ⇒ ('a × 'a) set ⇒ 'a set" for A r where
start: "⋀x. x ∈ A ⟹ x ∈ directed_towards A r"
| step: "⋀x y. y ∈ directed_towards A r ⟹ (x, y) ∈ r ⟹ x ∈ directed_towards A r"
hide_fact (open) start step
lemma directed_towards_mono:
assumes "s ∈ directed_towards A F" "F ⊆ G" shows "s ∈ directed_towards A G"
using assms by induct (auto intro: directed_towards.intros)
lemma directed_eq_rtrancl: "x ∈ directed_towards A r ⟷ (∃a∈A. (x, a) ∈ r⇧*)"
proof
assume "x ∈ directed_towards A r" then show "∃a∈A. (x, a) ∈ r⇧*"
by induction (auto intro: converse_rtrancl_into_rtrancl)
next
assume "∃a∈A. (x, a) ∈ r⇧*"
then obtain a where "(x, a) ∈ r⇧*" "a ∈ A" by auto
then show "x ∈ directed_towards A r"
by (induction rule: converse_rtrancl_induct)
(auto intro: directed_towards.start directed_towards.step)
qed
lemma directed_eq_rtrancl_Image: "directed_towards A r = (r⇧*)¯ `` A"
unfolding set_eq_iff directed_eq_rtrancl Image_iff by simp
locale Reachability_Problem = Finite_Markov_Decision_Process K S for K :: "'s ⇒ 's pmf set" and S +
fixes S1 S2 :: "'s set"
assumes S1: "S1 ⊆ S" and S2: "S2 ⊆ S" and S1_S2: "S1 ∩ S2 = {}"
begin
lemma [measurable]:
"S ∈ sets (count_space UNIV)" "S1 ∈ sets (count_space UNIV)" "S2 ∈ sets (count_space UNIV)"
by auto
definition
"v = (λcfg∈valid_cfg. emeasure (T cfg) {x∈space St. (HLD S1 suntil HLD S2) (state cfg ## x)})"
lemma v_eq: "cfg ∈ valid_cfg ⟹
v cfg = emeasure (T cfg) {x∈space St. (HLD S1 suntil HLD S2) (state cfg ## x)}"
by (auto simp add: v_def)
lemma real_v: "cfg ∈ valid_cfg ⟹ enn2real (v cfg) = 𝒫(ω in T cfg. (HLD S1 suntil HLD S2) (state cfg ## ω))"
by (auto simp add: v_def T.emeasure_eq_measure)
lemma v_le_1: "cfg ∈ valid_cfg ⟹ v cfg ≤ 1"
by (auto simp add: v_def T.emeasure_eq_measure)
lemma v_neq_Pinf[simp]: "cfg ∈ valid_cfg ⟹ v cfg ≠ top"
by (auto simp add: v_def)
lemma v_1_AE: "cfg ∈ valid_cfg ⟹ v cfg = 1 ⟷ (AE ω in T cfg. (HLD S1 suntil HLD S2) (state cfg ## ω))"
unfolding v_eq T.emeasure_eq_measure ennreal_eq_1 space_T[symmetric, of cfg]
by (rule T.prob_Collect_eq_1) simp
lemma v_0_AE: "cfg ∈ valid_cfg ⟹ v cfg = 0 ⟷ (AE x in T cfg. not (HLD S1 suntil HLD S2) (state cfg ## x))"
unfolding v_eq T.emeasure_eq_measure space_T[symmetric, of cfg] ennreal_eq_zero_iff[OF measure_nonneg]
by (rule T.prob_Collect_eq_0) simp
lemma v_S2[simp]: "cfg ∈ valid_cfg ⟹ state cfg ∈ S2 ⟹ v cfg = 1"
using S2 by (subst v_1_AE) (auto simp: suntil_Stream)
lemma v_nS12[simp]: "cfg ∈ valid_cfg ⟹ state cfg ∉ S1 ⟹ state cfg ∉ S2 ⟹ v cfg = 0"
by (subst v_0_AE) (auto simp: suntil_Stream)
lemma v_nS[simp]: "cfg ∉ valid_cfg ⟹ v cfg = undefined"
by (auto simp add: v_def)
lemma v_S1:
assumes cfg[simp, intro]: "cfg ∈ valid_cfg" and cfg_S1[simp]: "state cfg ∈ S1"
shows "v cfg = (∫⇧+s. v (cont cfg s) ∂action cfg)"
proof -
have [simp]: "state cfg ∉ S2"
using cfg_S1 S1_S2 S1 by blast
show ?thesis
by (auto simp: v_eq emeasure_Collect_T[of _ cfg] K_cfg_def map_pmf_rep_eq nn_integral_distr
AE_measure_pmf_iff suntil_Stream[of _ _ "state cfg"]
valid_cfg_cont
intro!: nn_integral_cong_AE)
qed
lemma real_v_integrable:
"integrable (action cfg) (λs. enn2real (v (cont cfg s)))"
by (rule measure_pmf.integrable_const_bound[where B="max 1 (enn2real undefined)"])
(auto simp add: v_def measure_def[symmetric] le_max_iff_disj)
lemma real_v_integral_eq:
assumes cfg[simp]: "cfg ∈ valid_cfg"
shows "enn2real (∫⇧+ s. v (cont cfg s) ∂action cfg) = ∫ s. enn2real (v (cont cfg s)) ∂action cfg"
by (subst integral_eq_nn_integral)
(auto simp: AE_measure_pmf_iff v_eq T.emeasure_eq_measure valid_cfg_cont
intro!: arg_cong[where f=enn2real] nn_integral_cong_AE)
lemma v_eq_0_coinduct[consumes 3, case_names valid nS2 cont]:
assumes *: "P cfg"
assumes valid: "⋀cfg. P cfg ⟹ cfg ∈ valid_cfg"
assumes nS2: "⋀cfg. P cfg ⟹ state cfg ∉ S2"
assumes cont: "⋀cfg cfg'. P cfg ⟹ state cfg ∈ S1 ⟹ cfg' ∈ K_cfg cfg ⟹ P cfg' ∨ v cfg' = 0"
shows "v cfg = 0"
proof -
from * valid[OF *]
have "AE x in MC_syntax.T K_cfg cfg. ¬ (HLD S1 suntil HLD S2) (state cfg ## smap state x)"
unfolding stream.map[symmetric] suntil_smap hld_smap'
proof (coinduction arbitrary: cfg rule: MC.AE_not_suntil_coinduct_strong)
case (ψ cfg) then show ?case
by (auto simp del: cfg_onD_state dest: nS2)
next
case (φ cfg' cfg)
then have *: "P cfg" "state cfg ∈ S1" "cfg' ∈ K_cfg cfg" and [simp, intro]: "cfg ∈ valid_cfg"
by auto
with cont[OF *] show ?case
by (subst (asm) v_0_AE)
(auto simp: suntil_Stream T_def AE_distr_iff suntil_smap hld_smap' cong del: AE_cong)
qed
then have "AE ω in T cfg. ¬ (HLD S1 suntil HLD S2) (state cfg ## ω)"
unfolding T_def by (subst AE_distr_iff) simp_all
with valid[OF *] show ?thesis
by (simp add: v_0_AE)
qed
definition "p = (λs∈S. P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω)))"
lemma p_eq_SUP_v: "s ∈ S ⟹ p s = ⨆ (v ` cfg_on s)"
by (auto simp add: p_def v_def P_sup_def T.emeasure_eq_measure intro: valid_cfgI intro!: SUP_cong cong: SUP_cong_simp)
lemma v_le_p: "cfg ∈ valid_cfg ⟹ v cfg ≤ p (state cfg)"
by (subst p_eq_SUP_v) (auto intro!: SUP_upper dest: valid_cfgD valid_cfg_state_in_S)
lemma p_eq_0_imp: "cfg ∈ valid_cfg ⟹ p (state cfg) = 0 ⟹ v cfg = 0"
using v_le_p[of cfg] by (auto intro: antisym)
lemma p_eq_0_iff: "s ∈ S ⟹ p s = 0 ⟷ (∀cfg∈cfg_on s. v cfg = 0)"
unfolding p_eq_SUP_v by (subst SUP_eq_iff) auto
lemma p_le_1: "s ∈ S ⟹ p s ≤ 1"
by (auto simp: p_eq_SUP_v intro!: SUP_least v_le_1 intro: valid_cfgI)
lemma p_undefined[simp]: "s ∉ S ⟹ p s = undefined"
by (simp add: p_def)
lemma p_not_inf[simp]: "s ∈ S ⟹ p s ≠ top"
using p_le_1[of s] by (auto simp: top_unique)
lemma p_S1: "s ∈ S1 ⟹ p s = (⨆D∈K s. ∫⇧+ t. p t ∂measure_pmf D)"
using S1 S1_S2 K_closed[of s] unfolding p_def
by (simp add: P_sup_iterate[of _ s] subset_eq set_eq_iff suntil_Stream[of _ _ s])
(auto intro!: SUP_cong nn_integral_cong_AE simp add: AE_measure_pmf_iff)
lemma p_S2[simp]: "s ∈ S2 ⟹ p s = 1"
using S2 by (auto simp: v_S2[OF valid_cfgI] p_eq_SUP_v)
lemma p_nS12: "s ∈ S ⟹ s ∉ S1 ⟹ s ∉ S2 ⟹ p s = 0"
by (auto simp: p_eq_SUP_v v_nS12[OF valid_cfgI])
lemma p_pos:
assumes "(s, t) ∈ (SIGMA s:S1. ⋃D∈K s. set_pmf D)⇧*" "t ∈ S2" shows "0 < p s"
using assms proof (induction rule: converse_rtrancl_induct)
case (step s t')
then obtain D where "s ∈ S1" "D ∈ K s" "t' ∈ D" "0 < p t'"
by auto
with S1 set_pmf_closed[of s D] have in_S: "⋀t. t ∈ D ⟹ t ∈ S"
by auto
from ‹t' ∈ D› ‹0 < p t'› have "0 < pmf D t' * p t'"
by (auto simp add: ennreal_zero_less_mult_iff pmf_positive)
also have "… ≤ (∫⇧+t. p t' * indicator {t'} t∂D)"
using in_S[OF ‹t' ∈ D›]
by (subst nn_integral_cmult_indicator) (auto simp: ac_simps emeasure_pmf_single)
also have "… ≤ (∫⇧+t. p t ∂D)"
by (auto intro!: nn_integral_mono_AE split: split_indicator simp: in_S AE_measure_pmf_iff
simp del: nn_integral_indicator_singleton)
also have "… ≤ p s"
using ‹s ∈ S1› ‹D ∈ K s› by (auto intro: SUP_upper simp add: p_S1)
finally show ?case .
qed simp
definition F_sup :: "('s ⇒ ennreal) ⇒ 's ⇒ ennreal" where
"F_sup f = (λs∈S. if s ∈ S2 then 1 else if s ∈ S1 then SUP D∈K s. ∫⇧+t. f t ∂measure_pmf D else 0)"
lemma F_sup_cong: "(⋀s. s ∈ S ⟹ f s = g s) ⟹ F_sup f s = F_sup g s"
using K_closed[of s]
by (auto simp: F_sup_def AE_measure_pmf_iff subset_eq
intro!: SUP_cong nn_integral_cong_AE)
lemma continuous_F_sup: "sup_continuous F_sup"
unfolding sup_continuous_def fun_eq_iff F_sup_def[abs_def]
by (auto simp: SUP_apply[abs_def] nn_integral_monotone_convergence_SUP intro: SUP_commute)
lemma mono_F_sup: "mono F_sup"
by (intro sup_continuous_mono continuous_F_sup)
lemma lfp_F_sup_iterate: "lfp F_sup = (SUP i. (F_sup ^^ i) (λx∈S. 0))"
proof -
{ have "(SUP i. (F_sup ^^ i) ⊥) = (SUP i. (F_sup ^^ i) (λx∈S. 0))"
proof (rule SUP_eq)
fix i show "∃j∈UNIV. (F_sup ^^ i) ⊥ ≤ (F_sup ^^ j) (λx∈S. 0)"
by (intro bexI[of _ i] funpow_mono mono_F_sup) auto
have *: "(λx∈S. 0) ≤ F_sup ⊥"
using K_wf by (auto simp: F_sup_def le_fun_def)
show "∃j∈UNIV. (F_sup ^^ i) (λx∈S. 0) ≤ (F_sup ^^ j) ⊥"
by (auto intro!: exI[of _ "Suc i"] funpow_mono mono_F_sup *
simp del: funpow.simps simp add: funpow_Suc_right le_funI)
qed }
then show ?thesis
by (auto simp: sup_continuous_lfp continuous_F_sup)
qed
lemma p_eq_lfp_F_sup: "p = lfp F_sup"
proof -
{ fix s assume "s ∈ S" let ?F = "λP. HLD S2 or (HLD S1 aand nxt P)"
have "P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω)) = (⨆i. P_sup s (λω. (?F ^^ i) ⊥ (s ## ω)))"
proof (simp add: suntil_def, rule P_sup_lfp)
show "(##) s ∈ measurable St St"
by simp
fix P assume P: "Measurable.pred St P"
show "Measurable.pred St (HLD S2 or (HLD S1 aand (λω. P (stl ω))))"
by (intro pred_intros_logic measurable_compose[OF _ P] measurable_compose[OF measurable_shd]) auto
qed (auto simp: sup_continuous_def)
also have "… = (SUP i. (F_sup ^^ i) (λx∈S. 0) s)"
proof (rule SUP_cong)
fix i from ‹s ∈ S› show "P_sup s (λω. (?F ^^ i) ⊥ (s##ω)) = (F_sup ^^ i) (λx∈S. 0) s"
proof (induct i arbitrary: s)
case (Suc n) show ?case
proof (subst P_sup_iterate)
show "Measurable.pred St (λω. (?F ^^ Suc n) ⊥ (s ## ω))"
apply (intro measurable_compose[OF measurable_Stream[OF measurable_const measurable_ident_sets[OF refl]] measurable_predpow])
apply simp
apply (simp add: bot_fun_def[abs_def])
apply (intro pred_intros_logic measurable_compose[OF measurable_stl] measurable_compose[OF measurable_shd])
apply auto
done
next
show "(⨆D∈K s. ∫⇧+ t. P_sup t (λω. (?F ^^ Suc n) ⊥ (s ## t ## ω)) ∂measure_pmf D) =
(F_sup ^^ Suc n) (λx∈S. 0) s"
unfolding funpow.simps comp_def
using S1 S2 ‹s ∈ S›
by (subst F_sup_cong[OF Suc(1)[symmetric]])
(auto simp add: F_sup_def measure_pmf.emeasure_space_1[simplified] K_wf subset_eq)
qed
qed simp
qed simp
finally have "lfp F_sup s = P_sup s (λω. (HLD S1 suntil HLD S2) (s ## ω))"
by (simp add: lfp_F_sup_iterate image_comp) }
moreover have "⋀s. s ∉ S ⟹ lfp F_sup s = undefined"
by (subst lfp_unfold[OF mono_F_sup]) (auto simp add: F_sup_def)
ultimately show ?thesis
by (auto simp: p_def)
qed
definition "S⇩e = {s∈S. p s = 0}"
lemma S⇩e: "S⇩e ⊆ S"
by (auto simp add: S⇩e_def)
lemma v_S⇩e: "cfg ∈ valid_cfg ⟹ state cfg ∈ S⇩e ⟹ v cfg = 0"
using p_eq_0_imp[of cfg] by (auto simp: S⇩e_def)
lemma S⇩e_nS2: "S⇩e ∩ S2 = {}"
by (auto simp: S⇩e_def)
lemma S⇩e_E1: "s ∈ S⇩e ∩ S1 ⟹ (s, t) ∈ E ⟹ t ∈ S⇩e"
unfolding S⇩e_def using S1
by (auto simp: p_S1 SUP_eq_iff K_wf nn_integral_0_iff_AE AE_measure_pmf_iff E_def
intro: set_pmf_closed antisym
cong: rev_conj_cong)
lemma S⇩e_E2: "s ∈ S1 ⟹ (⋀t. (s, t) ∈ E ⟹ t ∈ S⇩e) ⟹ s ∈ S⇩e"
unfolding S⇩e_def using S1 S1_S2
by (force simp: p_S1 SUP_eq_iff K_wf nn_integral_0_iff_AE AE_measure_pmf_iff E_def
cong: rev_conj_cong)
lemma S⇩e_E_iff: "s ∈ S1 ⟹ s ∈ S⇩e ⟷ (∀t. (s, t) ∈ E ⟶ t ∈ S⇩e)"
using S⇩e_E1[of s] S⇩e_E2[of s] by blast
definition "S⇩r = S - (S⇩e ∪ S2)"
lemma S⇩r: "S⇩r ⊆ S"
by (auto simp: S⇩r_def)
lemma S⇩r_S1: "S⇩r ⊆ S1"
by (auto simp: p_nS12 S⇩r_def S⇩e_def)
lemma S⇩r_eq: "S⇩r = S1 - S⇩e"
using S1_S2 S1 S2 by (auto simp add: S⇩r_def S⇩e_def p_nS12)
lemma v_neq_0_imp: "cfg ∈ valid_cfg ⟹ v cfg ≠ 0 ⟹ state cfg ∈ S⇩r ∪ S2"
using p_eq_0_imp[of cfg] by (auto simp add: S⇩r_def S⇩e_def valid_cfg_state_in_S)
lemma valid_cfg_action_in_K: "cfg ∈ valid_cfg ⟹ action cfg ∈ K (state cfg)"
by (auto dest!: valid_cfgD)
lemma K_cfg_E: "cfg ∈ valid_cfg ⟹ cfg' ∈ K_cfg cfg ⟹ (state cfg, state cfg') ∈ E"
by (auto simp: E_def K_cfg_def valid_cfg_action_in_K)
lemma S⇩r_directed_towards_S2:
assumes s: "s ∈ S⇩r"
shows "s ∈ directed_towards S2 {(s, t) | s t. s ∈ S⇩r ∧ (s, t) ∈ E}" (is "s ∈ ?D")
proof -
{ fix cfg assume "s ∉ ?D" "cfg ∈ cfg_on s"
with s S⇩r have "state cfg ∈ S⇩r" "state cfg ∉ ?D" "cfg ∈ valid_cfg"
by (auto intro: valid_cfgI)
then have "v cfg = 0"
proof (coinduction arbitrary: cfg rule: v_eq_0_coinduct)
case (cont cfg' cfg)
with v_neq_0_imp[of cfg'] show ?case
by (auto intro: directed_towards.intros K_cfg_E)
qed (auto intro: directed_towards.intros) }
with p_eq_0_iff[of s] s show ?thesis
unfolding S⇩r_def S⇩e_def by blast
qed
definition "proper ct ⟷ ct ∈ Pi⇩E S K ∧ (∀s∈S⇩r. v (simple ct s) > 0)"
lemma S⇩r_nS2: "s ∈ S⇩r ⟹ s ∉ S2"
by (auto simp: S⇩r_def)
lemma properD1: "proper ct ⟹ ct ∈ Pi⇩E S K"
by (auto simp: proper_def)
lemma proper_eq:
assumes ct[simp, intro]: "ct ∈ Pi⇩E S K"
shows "proper ct ⟷ S⇩r ⊆ directed_towards S2 (SIGMA s:S⇩r. ct s)"
(is "_ ⟷ _ ⊆ ?D")
proof -
have *[simp]: "⋀s. s ∈ S⇩r ⟹ s ∈ S" and ct': "ct ∈ Pi S K"
using ct by (auto simp: S⇩r_def simp del: ct)
{ fix s t have "s ∈ S ⟹ t ∈ ct s ⟹ t ∈ S"
using K_closed[of s] ct' by (auto simp add: subset_eq) }
note ct_closed = this
let ?C = "simple ct"
from ct have valid_C[simp]: "⋀s. s ∈ S ⟹ ?C s ∈ valid_cfg"
by (auto simp add: PiE_def)
{ fix s assume "s ∈ ?D"
then have "0 < v (?C s)"
proof induct
case (step s t)
then have s: "s ∈ S⇩r" and t: "t ∈ ct s" and [simp]: "s ∈ S"
by auto
with S⇩r_S1 ct have "v (?C s) = (∫⇧+t. v (?C t) ∂ct s)"
by (subst v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
also have "… ≠ 0"
using ct t step
by (subst nn_integral_0_iff_AE) (auto simp add: AE_measure_pmf_iff zero_less_iff_neq_zero)
finally show ?case
using ct by (auto simp add: less_le)
qed (subst v_S2, insert S2, auto) }
moreover
{ fix s assume s: "s ∉ ?D" "s ∈ S⇩r"
with ct' have C: "?C s ∈ cfg_on s" and [simp]: "s ∈ S"
by auto
from s have "v (?C s) = 0"
proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
case (cont cfg s)
with S1 obtain t where "cfg = ?C t" "t ∈ ct s" "s ∈ S"
by (auto simp: set_K_cfg subset_eq)
with cont(1,2) v_neq_0_imp[of "?C t"] ct_closed[of s t] show ?case
by (intro exI[of _ t] disjCI) (auto intro: directed_towards.intros)
qed (auto simp: S⇩r_nS2) }
ultimately show ?thesis
unfolding proper_def using ct by (force simp del: v_nS v_S2 v_nS12 ct)
qed
lemma exists_proper:
obtains ct where "proper ct"
proof atomize_elim
define r where "r = rec_nat S2 (λ_ S'. {s∈S⇩r. ∃t∈S'. (s, t) ∈ E})"
then have [simp]: "r 0 = S2" "⋀n. r (Suc n) = {s∈S⇩r. ∃t∈r n. (s, t) ∈ E}"
by simp_all
{ fix s assume "s ∈ S⇩r"
then have "s ∈ directed_towards S2 {(s, t) | s t. s ∈ S⇩r ∧ (s, t) ∈ E}"
by (rule S⇩r_directed_towards_S2)
from this ‹s∈S⇩r› have "∃n. s ∈ r n"
proof induction
case (step s t)
show ?case
proof cases
assume "t ∈ S2" with step.prems step.hyps show ?thesis
by (intro exI[of _ "Suc 0"]) force
next
assume "t ∉ S2"
with step obtain n where "t ∈ r n" "t ∈ S⇩r"
by (auto elim: directed_towards.cases)
with ‹t∈S⇩r› step.hyps show ?thesis
by (intro exI[of _ "Suc n"]) force
qed
qed (simp add: S⇩r_def) }
note r = this
{ fix s assume "s ∈ S"
have "∃D∈K s. s ∈ S⇩r ⟶ (∃t∈D. ∃n. t ∈ r n ∧ (∀m. s ∈ r m ⟶ n < m))"
proof cases
assume s: "s ∈ S⇩r"
define n where "n = (LEAST n. s ∈ r n)"
then have "s ∈ r n" and n: "⋀i. i < n ⟹ s ∉ r i"
using r s by (auto intro: LeastI_ex dest: not_less_Least)
with s have "n ≠ 0"
by (intro notI) (auto simp: S⇩r_def)
then obtain n' where "n = Suc n'"
by (cases n) auto
with ‹s ∈ r n› obtain t D where "D ∈ K s" "t ∈ D" "t ∈ r n'"
by (auto simp: E_def)
with n ‹n = Suc n'› s show ?thesis
by (auto intro!: bexI[of _ D] bexI[of _ t] exI[of _ n'] simp: not_less_eq[symmetric])
qed (insert K_wf ‹s∈S›, auto) }
then obtain ct where ct: "⋀s. s ∈ S ⟹ ct s ∈ K s"
"⋀s. s ∈ S ⟹ s ∈ S⇩r ⟹ ∃t∈ct s. ∃n. t ∈ r n ∧ (∀m. s ∈ r m ⟶ n < m)"
by metis
then have *: "restrict ct S ∈ Pi⇩E S K"
by auto
moreover
{ fix s assume "s ∈ S⇩r"
then obtain n where "s ∈ r n"
by (metis r)
with ‹s ∈ S⇩r› have "s ∈ directed_towards S2 (SIGMA s : S⇩r. ct s)"
proof (induction n arbitrary: s rule: less_induct)
case (less n s)
moreover with S⇩r have "s ∈ S" by auto
ultimately obtain t m where "t ∈ ct s" "t ∈ r m" "m < n"
using ct[of s] by (auto simp: E_def)
with less.IH[of m t] ‹s ∈ S⇩r› show ?case
by (cases m) (auto intro: directed_towards.intros)
qed }
ultimately show "∃ct. proper ct"
using S⇩r S2
by (auto simp: proper_eq[OF *] subset_eq
intro!: exI[of _ "restrict ct S"]
cong: Sigma_cong)
qed
definition "l_desc X ct l s ⟷
s ∈ directed_towards S2 (SIGMA s : X. {l s}) ∧
v (simple ct s) ≤ v (simple ct (l s)) ∧
l s ∈ maximal (λs. v (simple ct s)) (ct s)"
lemma exists_l_desc:
assumes ct: "proper ct"
shows "∃l∈S⇩r → S⇩r ∪ S2. ∀s∈S⇩r. l_desc S⇩r ct l s"
proof -
have ct_closed: "⋀s t. s ∈ S ⟹ t ∈ ct s ⟹ t ∈ S"
using ct K_closed by (auto simp: proper_def PiE_iff)
have ct_Pi: "ct ∈ Pi S K"
using ct by (auto simp: proper_def)
have "finite S⇩r"
using S_finite by (auto simp: S⇩r_def)
then show ?thesis
proof (induct rule: finite_induct_select)
case (select X)
then obtain l where l: "l ∈ X → X ∪ S2" and desc: "⋀s. s ∈ X ⟹ l_desc X ct l s"
by auto
obtain x where x: "x ∈ S⇩r - X"
using ‹X ⊂ S⇩r› by auto
then have "x ∈ S"
by (auto simp: S⇩r_def)
let ?C = "simple ct"
let ?v = "λs. v (?C s)" and ?E = "λs. set_pmf (ct s)"
let ?M = "λs. maximal ?v (?E s)"
have finite_E[simp]: "⋀s. s ∈ S ⟹ finite (?E s)"
using K_closed ct by (intro finite_subset[OF _ S_finite]) (auto simp: proper_def subset_eq)
have valid_C[simp]: "⋀s. s ∈ S ⟹ ?C s ∈ valid_cfg"
using ct by (auto simp: proper_def intro!: simple_valid_cfg)
have E_ne[simp]: "⋀s. ?E s ≠ {}"
by (rule set_pmf_not_empty)
have "∃s∈S⇩r - X. ∃t∈?M s. t ∈ S2 ∪ X"
proof (rule ccontr)
assume "¬ ?thesis"
then have not_M: "⋀s. s ∈ S⇩r - X ⟹ ?M s ∩ (S2 ∪ X) = {}"
by auto
let ?S⇩m = "maximal ?v (S⇩r - X)"
have "finite (S⇩r - X)" "S⇩r - X ≠ {}"
using ‹X ⊂ S⇩r› by (auto intro!: finite_subset[OF _ S_finite] simp: S⇩r_def)
from maximal_ne[OF this] obtain s⇩m where s⇩m: "s⇩m ∈ ?S⇩m"
by force
have "∃s⇩0∈?S⇩m. ∃t∈?E s⇩0. t ∉ ?S⇩m"
proof (rule ccontr)
assume "¬ ?thesis"
then have S⇩m: "⋀s⇩0 t. s⇩0 ∈ ?S⇩m ⟹ t ∈ ?E s⇩0 ⟹ t ∈ ?S⇩m" by blast
from ‹s⇩m ∈ ?S⇩m› have [simp]: "s⇩m ∈ S" and "s⇩m ∈ S⇩r"
by (auto simp: S⇩r_def dest: maximalD1)
from ‹s⇩m ∈ ?S⇩m› have "v (?C s⇩m) = 0"
proof (coinduction arbitrary: s⇩m rule: v_eq_0_coinduct)
case (cont t s⇩m) with S1 show ?case
by (intro exI[of _ "state t"] disjCI conjI S⇩m[of s⇩m "state t"])
(auto simp: set_K_cfg)
qed (auto simp: S⇩r_def ct_Pi dest!: maximalD1)
with ‹s⇩m ∈ S⇩r› ‹proper ct› show False
by (auto simp: proper_def)
qed
then obtain s⇩0 t where "s⇩0 ∈ ?S⇩m" and t: "t ∈ ?E s⇩0" "t ∉ ?S⇩m"
by metis
with S⇩r_S1 have s⇩0: "s⇩0 ∈ S⇩r - X" and [simp]: "s⇩0 ∈ S" and "s⇩0 ∈ S1"
by (auto simp: S⇩r_def dest: maximalD1)
from ‹proper ct› ‹s⇩0 ∈ S› s⇩0 have "?v s⇩0 ≠ 0"
by (auto simp add: proper_def)
then have "0 < ?v s⇩0" by (simp add: zero_less_iff_neq_zero)
{ fix t assume "t ∈ S⇩e ∪ S2 ∪ X" "t ∈ ?E s⇩0" and "?v s⇩0 ≤ ?v t"
moreover have "t ∈ S⇩e ⟹ ?v t = 0"
by (simp add: p_eq_0_imp S⇩e_def ct_Pi)
ultimately have t: "t ∈ S2 ∪ X" "t ∈ ?E s⇩0"
using ‹0 < ?v s⇩0› by (auto simp: S⇩e_def)
have "maximal ?v (?E s⇩0 ∩ (S2 ∪ X)) ≠ {}"
using finite_E t by (intro maximal_ne) auto
moreover
{ fix x y assume x: "x ∈ S2 ∪ X" "x ∈ ?E s⇩0"
and *: "∀y∈?E s⇩0 ∩ (S2 ∪ X). ?v y ≤ ?v x" and y: "y ∈ ?E s⇩0"
with S2 ‹s⇩0 ∈ S›[THEN ct_closed] have [simp]: "x ∈ S" "y ∈ S"
by auto
have "?v y ≤ ?v x"
proof cases
assume "y ∈ S⇩r - X"
then have "?v y ≤ ?v s⇩0"
using ‹s⇩0 ∈ ?S⇩m› by (auto intro: maximalD2)
also note ‹?v s⇩0 ≤ ?v t›
also have "?v t ≤ ?v x"
using * t by auto
finally show ?thesis .
next
assume "y ∉ S⇩r - X" with y * show ?thesis
by (auto simp: S⇩r_def v_S⇩e[of "?C y"] ct_Pi)
qed }
then have "maximal ?v (?E s⇩0 ∩ (S2 ∪ X)) ⊆ maximal ?v (?E s⇩0)"
by (auto simp: maximal_def)
moreover note not_M[OF s⇩0]
ultimately have False
by (blast dest: maximalD1) }
then have less_s⇩0: "⋀t. t ∈ S⇩e ∪ S2 ∪ X ⟹ t ∈ ?E s⇩0 ⟹ ?v t < ?v s⇩0"
by (auto simp add: not_le[symmetric])
let ?K = "ct s⇩0"
have "?v s⇩0 = (∫⇧+ x. ?v x ∂?K)"
using v_S1[of "?C s⇩0"] ‹s⇩0 ∈ S1› ‹s⇩0 ∈ S›
by (auto simp add: ct_Pi intro!: nn_integral_cong_AE AE_pmfI)
also have "… < (∫⇧+x. ?v s⇩0 ∂?K)"
proof (intro nn_integral_less)
have "(∫⇧+x. ?v x ∂?K) ≤ (∫⇧+x. 1 ∂?K)"
using ct ct_closed[of s⇩0]
by (intro nn_integral_mono_AE)
(auto intro!: v_le_1 simp: AE_measure_pmf_iff proper_def ct_Pi)
then show "(∫⇧+x. ?v x ∂?K) ≠ ∞"
by (auto simp: top_unique)
have "?v t < ?v s⇩0"
proof cases
assume "t ∈ S⇩e ∪ S2 ∪ X" then show ?thesis
using less_s⇩0[of t] t by simp
next
assume "t ∉ S⇩e ∪ S2 ∪ X"
with t(1) ct_closed[of s⇩0 t] have "t ∈ S⇩r - X"
unfolding S⇩r_def by (auto simp: E_def)
with t(2) show ?thesis
using ‹s⇩0 ∈ ?S⇩m› by (auto simp: maximal_def not_le intro: less_le_trans)
qed
then show "¬ (AE x in ?K. ?v s⇩0 ≤ ?v x)"
using t by (auto simp: not_le AE_measure_pmf_iff E_def cong del: AE_cong intro!: exI[of _ "t"])
show "AE x in ?K. ?v x ≤ ?v s⇩0"
proof (subst AE_measure_pmf_iff, safe)
fix t assume t: "t ∈ ?E s⇩0"
show "?v t ≤ ?v s⇩0"
proof cases
assume "t ∈ S⇩e ∪ S2 ∪ X" then show ?thesis
using less_s⇩0[of t] t by simp
next
assume "t ∉ S⇩e ∪ S2 ∪ X" with t ‹s⇩0 ∈ ?S⇩m› ‹s⇩0 ∈ S› show ?thesis
by (elim maximalD2) (auto simp: S⇩r_def intro!: ct_closed[of _ t])
qed
qed
qed (insert ct_closed[of s⇩0], auto simp: AE_measure_pmf_iff)
also have "… = ?v s⇩0"
using ‹s⇩0 ∈ S› measure_pmf.emeasure_space_1[of "ct s⇩0"] by simp
finally show False
by simp
qed
then obtain s t where s: "s ∈ S⇩r - X" and t: "t ∈ S2 ∪ X" "t ∈ ?M s"
by auto
with S2 ‹X ⊂ S⇩r› have "s ∉ S2" and "s ∈ S ∧ s ∉ S2" and "s ∉ X"and [simp]: "t ∈ S"
by (auto simp add: S⇩r_def)
define l' where "l' = l(s := t)"
then have l'_s[simp, intro]: "l' s = t"
by simp
let ?D = "λX l. directed_towards S2 (SIGMA s : X. {l s})"
{ fix s' assume "s' ∈ ?D X l" "s' ∈ X"
from this(1) have "s' ∈ ?D (insert s X) l'"
by (rule directed_towards_mono) (auto simp: l'_def ‹s ∉ X›) }
note directed_towards_l' = this
show ?case
proof (intro bexI ballI, elim insertE)
show "s ∈ S⇩r - X" by fact
show "l' ∈ insert s X → insert s X ∪ S2"
using s t l by (auto simp: l'_def)
next
fix s' assume s': "s' ∈ X"
moreover
from desc[OF s'] have "s' ∈ ?D X l" and *: "?v s' ≤ ?v (l s')" "l s' ∈ ?M s'"
by (auto simp: l_desc_def)
moreover have "l' s' = l s'"
using ‹s' ∈ X› s by (auto simp add: l'_def)
ultimately show "l_desc (insert s X) ct l' s'"
by (auto simp: l_desc_def intro!: directed_towards_l')
next
fix s' assume "s' = s"
show "l_desc (insert s X) ct l' s'"
unfolding ‹s' = s› l_desc_def l'_s
proof (intro conjI)
show "s ∈ ?D (insert s X) l'"
proof cases
assume "t ∉ S2"
with t have "t ∈ X" by auto
with desc have "t ∈ ?D X l"
by (simp add: l_desc_def)
then show ?thesis
by (force intro: directed_towards.step[OF directed_towards_l'] ‹t ∈ X›)
qed (force intro: directed_towards.step directed_towards.start)
from ‹s ∈ S⇩r - X› S⇩r_S1 have [simp]: "s ∈ S1" "s ∈ S"
by (auto simp: S⇩r_def)
show "?v s ≤ ?v t"
using t(2)[THEN maximalD2] ct
by (auto simp add: v_S1 AE_measure_pmf_iff proper_def Pi_iff PiE_def
intro!: measure_pmf.nn_integral_le_const)
qed fact
qed
qed simp
qed
lemma F_v_memoryless:
obtains ct where "ct ∈ Pi⇩E S K" "v∘simple ct = F_sup (v∘simple ct)"
proof atomize_elim
define R where "R = {(ct(s := D), ct) | ct s D.
ct ∈ Pi⇩E S K ∧ proper ct ∧ s ∈ S⇩r ∧ D ∈ K s ∧ v (simple ct s) < (∫⇧+t. v (simple ct t) ∂D) }"
{ fix ct ct' assume ct_ct': "(ct', ct) ∈ R"
let ?v = "λs. v (simple ct s)" and ?v' = "λs. v (simple ct' s)"
from ct_ct' obtain s D where "ct ∈ Pi⇩E S K" "proper ct" and s: "s ∈ S⇩r" and D: "D ∈ K s"
and not_maximal: "?v s < (∫⇧+t. ?v t ∂D)" and ct'_eq: "ct' = ct(s := D)"
by (auto simp: R_def)
with S⇩r_S1 have ct: "ct ∈ Pi S K" and "s ∈ S" and "s ∈ S1"
by (auto simp: S⇩r_def)
then have valid_ct[simp]: "⋀s. s ∈ S ⟹ simple ct s ∈ cfg_on s"
by simp
from ct'_eq have [simp]: "ct' s = D" "⋀t. t ≠ s ⟹ ct' t = ct t"
by simp_all
from ct_ct' S⇩r have ct'_E: "ct' ∈ Pi⇩E S K"
by (auto simp: ct'_eq R_def)
from ct s D have ct': "ct' ∈ Pi S K"
by (auto simp: ct'_eq)
then have valid_ct'[simp]: "⋀s. s ∈ S ⟹ simple ct' s ∈ cfg_on s"
by simp
from exists_l_desc[OF ‹proper ct›]
obtain l where l: "l ∈ S⇩r → S⇩r ∪ S2" and "⋀s. s ∈ S⇩r ⟹ l_desc S⇩r ct l s"
by auto
then have directed_l: "⋀s. s ∈ S⇩r ⟹ s ∈ directed_towards S2 (SIGMA s:S⇩r. {l s})"
and v_l_mono: "⋀s. s ∈ S⇩r ⟹ ?v s ≤ ?v (l s)"
and l_in_Ea: "⋀s. s ∈ S⇩r ⟹ l s ∈ ct s"
by (auto simp: l_desc_def dest!: maximalD1)
let ?E = "λct. SIGMA s:S⇩r. ct s"
let ?D = "λct. directed_towards S2 (?E ct)"
have finite_E[simp]: "⋀s. s ∈ S ⟹ finite (ct' s)"
using ct' K_closed by (intro rev_finite_subset[OF S_finite]) auto
have "maximal ?v (ct' s) ≠ {}"
using ct' D ‹s∈S› finite_E[of s] by (intro maximal_ne set_pmf_not_empty) (auto simp del: finite_E)
then obtain s' where s': "s' ∈ maximal ?v (ct' s)"
by blast
with K_closed[OF ‹s ∈ S›] D have "s' ∈ S"
by (auto dest!: maximalD1)
have "s' ≠ s"
proof
assume [simp]: "s' = s"
have "?v s < (∫⇧+t. ?v t ∂D)"
by fact
also have "… ≤ (∫⇧+t. ?v s ∂D)"
using ‹s ∈ S› s' D by (intro nn_integral_mono_AE) (auto simp: AE_measure_pmf_iff intro: maximalD2)
finally show False
using measure_pmf.emeasure_space_1[of D] by (simp add: ‹s ∈ S› ct)
qed
have "p s' ≠ 0"
proof
assume "p s' = 0"
then have "?v s' = 0"
using v_le_p[of "simple ct s'"] ct ‹s' ∈ S› by (auto intro!: antisym ct)
then have "(∫⇧+t. ?v t ∂D) = 0"
using maximalD2[OF s'] by (subst nn_integral_0_iff_AE) (auto simp: ‹s∈S› D AE_measure_pmf_iff)
then have "?v s < 0"
using not_maximal by auto
then show False
using ‹s∈S› by (simp add: ct)
qed
with ‹s' ∈ S› have "s' ∈ S2 ∪ S⇩r"
by (auto simp: S⇩r_def S⇩e_def)
have l_acyclic: "(s', s) ∉ (SIGMA s:S⇩r. {l s})^+"
proof
assume "(s', s) ∈ (SIGMA s:S⇩r. {l s})^+"
then have "?v s' ≤ ?v s"
by induct (blast intro: order_trans v_l_mono)+
also have "… < (∫⇧+t. ?v t ∂D)"
using not_maximal .
also have "… ≤ (∫⇧+t. ?v s' ∂D)"
using s' by (intro nn_integral_mono_AE) (auto simp: ‹s ∈ S› D AE_measure_pmf_iff intro: maximalD2)
finally show False
using measure_pmf.emeasure_space_1[of D] by (simp add:‹s' ∈ S› ct)
qed
from ‹s' ∈ S2 ∪ S⇩r› have "s' ∈ ?D ct'"
proof
assume "s' ∈ S⇩r"
then have "l s' ∈ directed_towards S2 (SIGMA s:S⇩r. {l s})"
using l directed_l[of "l s'"] by (auto intro: directed_towards.start)
moreover from ‹s' ∈ S⇩r› have "(s', l s') ∈ (SIGMA s:S⇩r. {l s})^+"
by auto
ultimately have "l s' ∈ ?D ct'"
proof induct
case (step t t')
then have t: "t ≠ s" "t ∈ S⇩r" "t' = l t"
using l_acyclic by auto
from step have "(s', t') ∈ (SIGMA s:S⇩r. {l s})⇧+"
by (blast intro: trancl_into_trancl)
from step(2)[OF this] show ?case
by (rule directed_towards.step) (simp add: l_in_Ea t)
qed (rule directed_towards.start)
then show "s' ∈ ?D ct'"
by (rule directed_towards.step)
(simp add: l_in_Ea ‹s' ∈ S⇩r› ‹s ∈ S⇩r› ‹s' ≠ s›)
qed (rule directed_towards.start)
have proper: "proper ct'"
unfolding proper_eq[OF ct'_E]
proof
fix t assume "t ∈ S⇩r"
from directed_l[OF this] show "t ∈ ?D ct'"
proof induct
case (step t t')
show ?case
proof cases
assume "t = s"
with ‹s ∈ S⇩r› s'[THEN maximalD1] have "(t, s') ∈ ?E ct'"
by auto
with ‹s' ∈ ?D ct'› show ?thesis
by (rule directed_towards.step)
next
assume "t ≠ s"
with step have "(t, t') ∈ ?E ct'"
by (auto simp: l_in_Ea)
with step.hyps(2) show ?thesis
by (rule directed_towards.step)
qed
qed (rule directed_towards.start)
qed
have "?v ≤ ?v'"
proof (intro le_funI leI notI)
fix t' assume *: "?v' t' < ?v t'"
then have "t' ∈ S"
by (metis v_nS simple_valid_cfg_iff ct' ct order.irrefl)
define Δ where "Δ t = enn2real (?v t) - enn2real (?v' t)" for t
with * ‹t' ∈ S› have "0 < Δ t'"
by (cases "?v t'" "?v' t'" rule: ennreal2_cases) (auto simp add: ct' ct ennreal_less_iff)
{ fix t assume t: "t ∈ maximal Δ S"
with ‹t' ∈ S› have "Δ t' ≤ Δ t"
by (auto intro: maximalD2)
with ‹0 < Δ t'› have "0 < Δ t" by simp
with t have "t ∈ S⇩r"
by (auto simp add: S⇩r_def v_S⇩e ct ct' Δ_def dest!: maximalD1) }
note max_is_S⇩r = this
{ fix s assume "s ∈ S"
with v_le_1[of "simple ct' s"] v_le_1[of "simple ct s"]
have "¦Δ s¦ ≤ 1"
by (cases "?v s" "?v' s" rule: ennreal2_cases) (auto simp: Δ_def ct ct') }
note Δ_le_1[simp] = this
then have ennreal_Δ: "⋀s. s ∈ S ⟹ Δ s = ?v s - ?v' s"
by (auto simp add: Δ_def v_def T.emeasure_eq_measure ct ct' ennreal_minus)
from ‹s ∈ S› S_finite have "maximal Δ S ≠ {}"
by (intro maximal_ne) auto
then obtain t where "t ∈ maximal Δ S" by auto
from max_is_S⇩r[OF this] proper have "t ∈ ?D ct'"
unfolding proper_eq[OF ct'_E] by auto
from this ‹t ∈ maximal Δ S› show False
proof induct
case (start t)
then have "t ∈ S⇩r"
by (intro max_is_S⇩r)
with ‹t ∈ S2› show False
by (auto simp: S⇩r_def)
next
case (step t t')
then have t': "t' ∈ ct' t" and "t ∈ S⇩r" and t: "t ∈ maximal Δ S"
by (auto intro: max_is_S⇩r simp: comp_def)
then have "t' ∈ S" "t ∈ S1" "t ∈ S"
using S⇩r_S1 S1
by (auto simp: Pi_closed[OF ct'])
have "Δ t ≤ Δ t'"
proof (intro leI notI)
assume less: "Δ t' < Δ t"
have "(∫s. Δ s ∂ct' t) < (∫s. Δ t ∂ct' t)"
proof (intro measure_pmf.integral_less_AE)
show "emeasure (ct' t) {t'} ≠ 0" "{t'} ∈ sets (ct' t)"
"AE s in ct' t. s∈{t'} ⟶ Δ s ≠ Δ t"
using t' less by (auto simp add: emeasure_pmf_single_eq_zero_iff)
show "AE s in ct' t. Δ s ≤ Δ t"
using ct' ct t D
by (auto simp add: AE_measure_pmf_iff ct ‹t∈S› Pi_iff E_def Pi_closed[OF ct']
intro!: maximalD2[of t Δ] intro: Pi_closed[OF ct'] maximalD1)
show "integrable (ct' t) (λ_. Δ t)" "integrable (ct' t) Δ"
using ct ct' ‹t ∈ S› D
by (auto intro!: measure_pmf.integrable_const_bound[where B=1] Δ_le_1
simp: AE_measure_pmf_iff dest: Pi_closed)
qed
also have "… = Δ t"
using measure_pmf.prob_space[of "ct' t"] by simp
also have "Δ t ≤ (∫s. enn2real (?v s) ∂ct' t) - (∫s. enn2real (?v' s) ∂ct' t)"
proof -
have "?v t ≤ (∫⇧+s. ?v s ∂ct' t)"
proof cases
assume "t = s" with not_maximal show ?thesis by simp
next
assume "t ≠ s" with S1 ‹t∈S1› ‹t ∈ S› ct ct' show ?thesis
by (subst v_S1) (auto intro!: nn_integral_mono_AE AE_pmfI)
qed
also have "… = ennreal (∫s. enn2real (?v s) ∂ct' t)"
using ct ct' ‹t∈S›
by (intro measure_pmf.ennreal_integral_real[symmetric, where B=1])
(auto simp: AE_measure_pmf_iff one_ennreal_def[symmetric]
intro!: v_le_1 simple_valid_cfg intro: Pi_closed)
finally have "enn2real (?v t) ≤ (∫s. enn2real (?v s) ∂ct' t)"
using ct ‹t∈S› by (simp add: v_def T.emeasure_eq_measure)
moreover
{ have "?v' t = (∫⇧+s. ?v' s ∂ct' t)"
using ct ct' ‹t ∈ S› ‹t ∈ S1› S1 by (subst v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
also have "… = ennreal (∫s. enn2real (?v' s) ∂ct' t)"
using ct' ‹t∈S›
by (intro measure_pmf.ennreal_integral_real[symmetric, where B=1])
(auto simp: AE_measure_pmf_iff one_ennreal_def[symmetric]
intro!: v_le_1 simple_valid_cfg intro: Pi_closed)
finally have "enn2real (?v' t) = (∫s. enn2real (?v' s) ∂ct' t)"
using ct' ‹t∈S› by (simp add: v_def T.emeasure_eq_measure) }
ultimately show ?thesis
using ‹t ∈ S› by (simp add: Δ_def ennreal_minus_mono)
qed
also have "… = (∫s. Δ s ∂ct' t)"
unfolding Δ_def using Pi_closed[OF ct ‹t∈S›] Pi_closed[OF ct' ‹t∈S›] ct ct'
by (intro Bochner_Integration.integral_diff[symmetric] measure_pmf.integrable_const_bound[where B=1])
(auto simp: AE_measure_pmf_iff real_v)
finally show False
by simp
qed
with t[THEN maximalD2] ‹t ∈ S› ‹t' ∈ S› have "Δ t = Δ t'"
by (auto intro: antisym)
with t ‹t' ∈ S› have "t' ∈ maximal Δ S"
by (auto simp: maximal_def)
then show ?case
by fact
qed
qed
moreover have "?v s < ?v' s"
proof -
have "?v s < (∫⇧+t. ?v t ∂D)"
by fact
also have "… ≤ (∫⇧+t. ?v' t ∂D)"
using ‹?v ≤ ?v'› ‹s∈S› D ct ct'
by (intro nn_integral_mono) (auto simp: le_fun_def)
also have "… = ?v' s"
using ‹s∈S1› S1 ct' ‹s ∈ S› by (subst (2) v_S1) (auto intro!: nn_integral_cong_AE AE_pmfI)
finally show ?thesis .
qed
ultimately have "?v < ?v'"
by (auto simp: less_le le_fun_def fun_eq_iff)
note this proper ct' }
note v_strict = this(1) and proper = this(2) and sc'_R = this(3)
have "finite (Pi⇩E S K × Pi⇩E S K)"
by (intro finite_PiE S_finite K_finite finite_SigmaI)
then have "finite R"
by (rule rev_finite_subset) (auto simp add: PiE_iff S⇩r_def R_def intro: extensional_arb)
moreover
from v_strict have "acyclic R"
by (rule acyclicI_order)
ultimately have "wf R"
by (rule finite_acyclic_wf)
from exists_proper obtain ct' where ct': "proper ct'" .
define ct where "ct = restrict ct' S"
with ct' have sc_Pi: "ct ∈ Pi S K" and "ct' ∈ Pi S K"
by (auto simp: proper_def)
then have ct: "ct ∈ {ct ∈ Pi⇩E S K. proper ct}"
using ct' directed_towards_mono[where F="SIGMA s:S⇩r. ct' s" and G="SIGMA s:S⇩r. ct s"]
apply simp
apply (subst proper_eq)
by (auto simp: ct_def proper_eq[OF properD1[OF ct']] subset_eq S⇩r_def)
show "∃ct. ct ∈ Pi⇩E S K ∧ v∘simple ct = F_sup (v∘simple ct)"
proof (rule wfE_min[OF ‹wf R› ct])
fix ct assume ct: "ct ∈ {ct ∈ Pi⇩E S K. proper ct}"
then have "ct ∈ Pi S K" "proper ct"
by (auto simp: proper_def)
assume min: "⋀ct'. (ct', ct) ∈ R ⟹ ct' ∉ {ct ∈ Pi⇩E S K. proper ct}"
let ?v = "λs. v (simple ct s)"
{ fix s assume "s ∈ S" "s ∈ S1" "s ∉ S2"
with ct have "ct s ∈ K s" "?v s ≤ integral⇧N (ct s) ?v"
by (auto simp: v_S1 PiE_def intro!: nn_integral_mono_AE AE_pmfI)
moreover
{ have "0 ≤ ?v s"
using ‹s∈S› ct by (simp add: PiE_def)
also assume v_less: "?v s < (⨆D∈K s. ∫⇧+ s. v (simple ct s) ∂measure_pmf D)"
also have "… ≤ p s"
unfolding p_S1[OF ‹s∈S1›] using ‹s∈S› ct v_le_p[OF simple_valid_cfg, OF ‹ct ∈ Pi S K›]
by (auto intro!: SUP_mono nn_integral_mono_AE bexI
simp: PiE_def AE_measure_pmf_iff set_pmf_closed)
finally have "s ∈ S⇩r"
using ‹s∈S› ‹s∉S2› by (simp add: S⇩r_def S⇩e_def)
from v_less obtain D where "D ∈ K s" "?v s < integral⇧N D ?v"
by (auto simp: less_SUP_iff)
with ct ‹s∈S› ‹s∈S⇩r› have "(ct(s:=D), ct) ∈ R" "ct(s:=D) ∈ Pi⇩E S K"
unfolding R_def by (auto simp: PiE_def extensional_def)
from proper[OF this(1)] min[OF this(1)] ct ‹D ∈ K s› ‹s∈S› this(2)
have False
by simp }
ultimately have "?v s = (⨆D∈K s. ∫⇧+ s. ?v s ∂measure_pmf D)"
by (auto intro: antisym SUP_upper2[where i="ct s"] leI)
also have "… = (⨆D∈K s. integral⇧N (measure_pmf D) (λs∈S. ?v s))"
using ‹s∈S› by (auto intro!: SUP_cong nn_integral_cong v_nS simp: ct simple_valid_cfg_iff ‹ct ∈ Pi S K›)
finally have "?v s = (⨆D∈K s. integral⇧N (measure_pmf D) (λs∈S. ?v s))" . }
then have "?v = F_sup ?v"
unfolding F_sup_def using ct
by (auto intro!: ext v_S2 simple_cfg_on v_nS v_nS12 SUP_cong nn_integral_cong
simp: PiE_def simple_valid_cfg_iff)
with ct show ?thesis
by (auto simp: comp_def)
qed
qed
lemma p_v_memoryless:
obtains ct where "ct ∈ Pi⇩E S K" "p = v∘simple ct"
proof -
obtain ct where ct_PiE: "ct ∈ Pi⇩E S K" and eq: "v∘simple ct = F_sup (v∘simple ct)"
by (rule F_v_memoryless)
then have ct: "ct ∈ Pi S K"
by (simp add: PiE_def)
have "p = v∘simple ct"
proof (rule antisym)
show "p ≤ v∘simple ct"
unfolding p_eq_lfp_F_sup by (rule lfp_lowerbound) (metis order_refl eq)
show "v∘simple ct ≤ p"
proof (rule le_funI)
fix s show "(v∘simple ct) s ≤ p s"
using v_le_p[of "simple ct s"]
by (cases "s ∈ S") (auto simp del: simp add: v_def ct)
qed
qed
with ct_PiE that show thesis by auto
qed
definition "n = (λs∈S. P_inf s (λω. (HLD S1 suntil HLD S2) (s ## ω)))"
lemma n_eq_INF_v: "s ∈ S ⟹ n s = (⨅cfg∈cfg_on s. v cfg)"
by (auto simp add: n_def v_def P_inf_def T.emeasure_eq_measure valid_cfgI intro!: INF_cong)
lemma n_le_v: "s ∈ S ⟹ cfg ∈ cfg_on s ⟹ n s ≤ v cfg"
by (subst n_eq_INF_v) (blast intro!: INF_lower)+
lemma n_eq_1_imp: "s ∈ S ⟹ cfg ∈ cfg_on s ⟹ n s = 1 ⟹ v cfg = 1"
using n_le_v[of s cfg] v_le_1[of cfg] by (auto intro: antisym valid_cfgI)
lemma n_eq_1_iff: "s ∈ S ⟹ n s = 1 ⟷ (∀cfg∈cfg_on s. v cfg = 1)"
apply rule
apply (metis n_eq_1_imp)
apply (auto simp: n_eq_INF_v intro!: INF_eqI)
done
lemma n_le_1: "s ∈ S ⟹ n s ≤ 1"
by (auto simp: n_eq_INF_v intro!: INF_lower2[OF simple_cfg_on[of arb_act]] v_le_1)
lemma n_undefined[simp]: "s ∉ S ⟹ n s = undefined"
by (simp add: n_def)
lemma n_eq_0: "s ∈ S ⟹ cfg ∈ cfg_on s ⟹ v cfg = 0 ⟹ n s = 0"
using n_le_v[of s cfg] by auto
lemma n_not_inf[simp]: "s ∈ S ⟹ n s ≠ top"
using n_le_1[of s] by (auto simp: top_unique)
lemma n_S1: "s ∈ S1 ⟹ n s = (⨅D∈K s. ∫⇧+ t. n t ∂measure_pmf D)"
using S1 S1_S2 unfolding n_def
apply auto
apply (subst P_inf_iterate)
apply (auto intro!: nn_integral_cong_AE INF_cong intro: set_pmf_closed
simp: AE_measure_pmf_iff suntil_Stream set_eq_iff)
done
lemma n_S2[simp]: "s ∈ S2 ⟹ n s = 1"
using S2 by (auto simp add: n_eq_INF_v valid_cfgI)
lemma n_nS12: "s ∈ S ⟹ s ∉ S1 ⟹ s ∉ S2 ⟹ n s = 0"
by (auto simp add: n_eq_INF_v valid_cfgI)
lemma n_pos:
assumes "P s" "s ∈ S1" "wf R"
assumes cont: "⋀s D. P s ⟹ s ∈ S1 ⟹ D ∈ K s ⟹ ∃w∈D. ((w, s) ∈ R ∧ w ∈ S1 ∧ P w) ∨ 0 < n w"
shows "0 < n s"
using ‹wf R› ‹P s› ‹s∈S1›
proof (induction s)
case (less s)
with S1 have [simp]: "s ∈ S" by auto
let ?I = "λD::'s pmf. ∫⇧+t. n t ∂D"
have "0 < Min (?I`K s)"
proof (safe intro!: Min_gr_iff [THEN iffD2])
fix D assume [simp]: "D ∈ K s"
from cont[OF ‹P s› ‹s ∈ S1› ‹D ∈ K s›]
obtain w where w: "w ∈ D" "0 < n w"
by (force intro: less.IH)
have in_S: "⋀t. t ∈ D ⟹ t ∈ S"
using set_pmf_closed[OF ‹s ∈ S› ‹D ∈ K s›] by auto
from w have "0 < pmf D w * n w"
by (simp add: pmf_positive ennreal_zero_less_mult_iff)
also have "… = (∫⇧+t. n w * indicator {w} t ∂D)"
by (subst nn_integral_cmult_indicator)
(auto simp: ac_simps emeasure_pmf_single in_S ‹w ∈ D›)
also have "… ≤ (∫⇧+t. n t ∂D)"
by (intro nn_integral_mono_AE) (auto split: split_indicator simp: AE_measure_pmf_iff in_S)
finally show "0 < (∫⇧+t. n t ∂D)" .
qed (insert K_wf K_finite ‹s∈S›, auto)
also have "… = n s"
unfolding n_S1[OF ‹s ∈ S1›]
using K_wf K_finite ‹s∈S› by (intro Min_Inf) auto
finally show "0 < n s" .
qed
definition F_inf :: "('s ⇒ ennreal) ⇒ ('s ⇒ ennreal)" where
"F_inf f = (λs∈S. if s ∈ S2 then 1 else if s ∈ S1 then (⨅D∈K s. ∫⇧+ t. f t ∂measure_pmf D) else 0)"
lemma F_inf_n: "F_inf n = n"
by (simp add: F_inf_def n_nS12 n_S1 fun_eq_iff)
lemma F_inf_nS[simp]: "s ∉ S ⟹ F_inf f s = undefined"
by (simp add: F_inf_def)
lemma mono_F_inf: "mono F_inf"
by (auto intro!: INF_superset_mono nn_integral_mono simp: mono_def F_inf_def le_fun_def)
lemma S1_nS2: "s ∈ S1 ⟹ s ∉ S2"
using S1_S2 by auto
lemma n_eq_lfp_F_inf: "n = lfp F_inf"
proof (intro antisym lfp_lowerbound le_funI)
fix s let ?I = "λD. (∫⇧+t. lfp F_inf t ∂measure_pmf D)"
define ct where "ct s = (SOME D. D ∈ K s ∧ (s ∈ S1 ⟶ lfp F_inf s = ?I D))" for s
{ fix s assume s: "s ∈ S"
then have "finite (?I ` K s)"
by (auto intro: K_finite)
with s obtain D where "D ∈ K s" "(∫⇧+t. lfp F_inf t ∂D) = Min (?I ` K s)"
by (auto simp: K_wf dest!: Min_in)
note this(2)
also have "… = (INF D ∈ K s. ?I D)"
using s K_wf by (subst Min_Inf) (auto intro: K_finite)
also have "s ∈ S1 ⟹ … = lfp F_inf s"
using s S1_S2 by (subst (3) lfp_unfold[OF mono_F_inf]) (auto simp add: F_inf_def)
finally have "∃D. D ∈ K s ∧ (s ∈ S1 ⟶ lfp F_inf s = ?I D)"
using ‹D ∈ K s› by auto
then have "ct s ∈ K s ∧ (s ∈ S1 ⟶ lfp F_inf s = ?I (ct s))"
unfolding ct_def by (rule someI_ex)
then have "ct s ∈ K s" "s ∈ S1 ⟹ lfp F_inf s = ?I (ct s)"
by auto }
note ct = this
then have Pi_ct: "ct ∈ Pi S K"
by auto
then have valid_ct[simp]: "⋀s. s ∈ S ⟹ simple ct s ∈ valid_cfg"
by simp
let ?F = "λP. HLD S2 or (HLD S1 aand nxt P)"
define P where "P s n =
emeasure (T (simple ct s)) {x∈space (T (simple ct s)). (?F ^^ n) (λx. False) (s ## x)}"
for s n
{ assume "s ∈ S"
with S1 have [simp, measurable]: "s ∈ S" by auto
then have "n s ≤ v (simple ct s)"
by (intro n_le_v) (auto intro: simple_cfg_on[OF Pi_ct])
also have "… = emeasure (T (simple ct s)) {x∈space (T (simple ct s)). lfp ?F (s ## x)}"
using S1_S2
by (simp add: v_eq[OF simple_valid_cfg[OF Pi_ct ‹s∈S›]])
(simp add: suntil_lfp space_T[symmetric, of "simple ct s"] del: space_T)
also have "… = (⨆n. P s n)" unfolding P_def
apply (rule emeasure_lfp2[where P="λM. ∃s. M = T (simple ct s)" and M="T (simple ct s)"])
apply (intro exI[of _ s] refl)
apply (auto simp: sup_continuous_def) []
apply auto []
proof safe
fix A s assume "⋀N. ∃s. N = T (simple ct s) ⟹ Measurable.pred N A"
then have "⋀s. Measurable.pred (T (simple ct s)) A"
by metis
then have "⋀s. Measurable.pred St A"
by simp
then show "Measurable.pred (T (simple ct s)) (λxs. HLD S2 xs ∨ HLD S1 xs ∧ nxt A xs)"
by simp
qed
also have "… ≤ lfp F_inf s"
proof (intro SUP_least)
fix n from ‹s∈S› show "P s n ≤ lfp F_inf s"
proof (induct n arbitrary: s)
case 0 with S1 show ?case
by (subst lfp_unfold[OF mono_F_inf]) (auto simp: P_def)
next
case (Suc n)
show ?case
proof cases
assume "s ∈ S1" with S1_S2 S1 have s[simp]: "s ∉ S2" "s ∈ S" "s ∈ S1" by auto
have "P s (Suc n) = (∫⇧+t. P t n ∂ct s)"
unfolding P_def space_T
apply (subst emeasure_Collect_T)
apply (rule measurable_compose[OF measurable_Stream[OF measurable_const measurable_ident_sets[OF refl]]])
apply (measurable, assumption)
apply (auto simp: K_cfg_def map_pmf_rep_eq nn_integral_distr
intro!: nn_integral_cong_AE AE_pmfI)
done
also have "… ≤ (∫⇧+t. lfp F_inf t ∂ct s)"
using Pi_closed[OF Pi_ct ‹s ∈ S›]
by (auto intro!: nn_integral_mono_AE Suc simp: AE_measure_pmf_iff)
also have "… = lfp F_inf s"
by (intro ct(2)[symmetric]) auto
finally show ?thesis .
next
assume "s ∉ S1" with S2 ‹s ∈ S› show ?case
using T.emeasure_space_1[of "simple ct s"]
by (subst lfp_unfold[OF mono_F_inf]) (auto simp: F_inf_def P_def)
qed
qed
qed
finally have "n s ≤ lfp F_inf s" . }
moreover have "s ∉ S ⟹ n s ≤ lfp F_inf s"
by (subst lfp_unfold[OF mono_F_inf]) (simp add: n_def F_inf_def)
ultimately show "n s ≤ lfp F_inf s"
by blast
qed (simp add: F_inf_n)
lemma real_n: "s ∈ S ⟹ ennreal (enn2real (n s)) = n s"
by (cases "n s") simp_all
lemma real_p: "s ∈ S ⟹ ennreal (enn2real (p s)) = p s"
by (cases "p s") simp_all
lemma p_ub:
fixes x
assumes "s ∈ S"
assumes solution: "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ (∑t∈S. pmf D t * x t) ≤ x s"
assumes solution_0: "⋀s. s ∈ S ⟹ p s = 0 ⟹ x s = 0"
assumes solution_S2: "⋀s. s ∈ S2 ⟹ x s = 1"
shows "enn2real (p s) ≤ x s" (is "?y s ≤ _")
proof -
let ?p = "λs. enn2real (p s)"
from p_v_memoryless obtain sc where "sc ∈ Pi⇩E S K" and p_eq: "p = v ∘ simple sc"
by auto
then have sch: "⋀s. s ∈ S ⟹ sc s ∈ K s" and sc_Pi: "sc ∈ Pi S K"
by (auto simp: PiE_iff)
interpret sc: MC_syntax sc .
define N where "N = {s∈S. p s = 0} ∪ S2"
{ fix s assume "s ∈ S" "s ∉ N"
with p_nS12 have "s ∈ S1"
by (auto simp add: N_def) }
note N = this
have N_S: "N ⊆ S"
using S2 by (auto simp: N_def)
have finite_sc[intro]: "s ∈ S ⟹ finite (sc s)" for s
using ‹sc ∈ Pi⇩E S K› by (auto simp: PiE_iff intro: set_pmf_finite)
show ?thesis
proof cases
assume "s ∈ S - N"
then show ?thesis
proof (rule mono_les)
show "(⋃x∈S - N. set_pmf (sc x)) ⊆ S - N ∪ N"
using Pi_closed[OF sc_Pi] by auto
show "finite ((λs. ?p s - x s) ` (S - N ∪ N))"
using N_S by (intro finite_imageI finite_subset[OF _ S_finite]) auto
next
fix s assume "s ∈ N" then show "?p s ≤ x s"
by (auto simp: N_def solution_S2 solution_0)
next
fix s assume s: "s ∈ S - N"
then show "integrable (sc s) x" "integrable (sc s) ?p"
by (auto intro!: integrable_measure_pmf_finite set_pmf_finite sch)
from s have "s ∈ S1" "s ∈ S"
using p_nS12[of s] by (auto simp: N_def)
then show "?p s ≤ (∫ t. ?p t ∂sc s) + 0"
unfolding p_eq using real_v_integral_eq[of "simple sc s"]
by (auto simp add: v_S1 sc_Pi intro!: integral_mono_AE integrable_measure_pmf_finite AE_pmfI)
show "(∫ t. x t ∂sc s) + 0 ≤ x s"
using solution[OF ‹s ∈ S1› sch[OF ‹s ∈ S›]]
by (subst integral_measure_pmf[where A=S])
(auto intro: S_finite Pi_closed[OF sc_Pi] ‹s ∈ S› simp: ac_simps)
define X where "X = (SIGMA x:UNIV. sc x)"
show "∃t∈N. (s, t) ∈ X⇧*"
proof (rule ccontr)
assume "¬ ?thesis"
then have *: "∀t∈N. (s, t) ∉ X⇧*"
by auto
with ‹s∈S› have "v (simple sc s) = 0"
proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
case (valid t) with sch show ?case
by auto
next
case (nS2 s) then show ?case
by (auto simp: N_def)
next
case (cont cfg s)
then have "(s, state cfg) ∈ X⇧*"
by (auto simp: X_def set_K_cfg)
with cont show ?case
by (auto simp: set_K_cfg intro!: exI intro: Pi_closed[OF sc_Pi])
(blast intro: rtrancl_trans)
qed
then have "p s = 0"
unfolding p_eq by simp
with ‹s∈S› have "s∈N"
by (auto simp: N_def)
with * show False
by auto
qed
qed
next
assume "s ∉ S - N" with ‹s ∈ S› show "?p s ≤ x s"
by (auto simp: N_def solution_0 solution_S2)
qed
qed
lemma n_lb:
fixes x
assumes "s ∈ S"
assumes solution: "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ x s ≤ (∑t∈S. pmf D t * x t)"
assumes solution_n0: "⋀s. s ∈ S ⟹ n s = 0 ⟹ x s = 0"
assumes solution_S2: "⋀s. s ∈ S2 ⟹ x s = 1"
shows "x s ≤ enn2real (n s)" (is "_ ≤ ?y s")
proof -
let ?I = "λD::'s pmf. ∫⇧+x. n x ∂D"
{ fix s assume "s ∈ S1"
with S1 S1_S2 have "n s = (⨅D∈K s. ?I D)"
by (subst n_eq_lfp_F_inf, subst lfp_unfold[OF mono_F_inf])
(auto simp add: F_inf_def n_eq_lfp_F_inf)
moreover have "(⨅D∈K s. ∫⇧+x. n x ∂measure_pmf D) = Min (?I`K s)"
using ‹s ∈ S1› S1 K_wf
by (intro cInf_eq_Min finite_imageI K_finite) auto
moreover have "Min (?I`K s) ∈ ?I`K s"
using ‹s ∈ S1› S1 K_wf by (intro Min_in finite_imageI K_finite) auto
ultimately have "∃D∈K s. (∫⇧+x. n x ∂D) = n s"
by auto }
then have "⋀s. s ∈ S ⟹ ∃D∈K s. s ∈ S1 ⟶ (∫⇧+x. n x ∂D) = n s"
using K_wf by auto
then obtain sc where sch: "⋀s. s ∈ S ⟹ sc s ∈ K s"
and n_sc: "⋀s. s ∈ S1 ⟹ (∫⇧+x. n x ∂sc s) = n s"
by (metis S1 subsetD)
then have sc_Pi: "sc ∈ Pi S K"
by auto
define N where "N = {s∈S. n s = 0} ∪ S2"
with S2 have N_S: "N ⊆ S"
by auto
{ fix s assume "s ∈ S" "s ∉ N"
with n_nS12 have "s ∈ S1"
by (auto simp add: N_def) }
note N = this
let ?n = "λs. enn2real (n s)"
show ?thesis
proof cases
assume "s ∈ S - N"
then show ?thesis
proof (rule mono_les)
show "(⋃x∈S - N. set_pmf (sc x)) ⊆ S - N ∪ N"
using Pi_closed[OF sc_Pi] by auto
show "finite ((λs. x s - ?n s) ` (S - N ∪ N))"
using N_S by (intro finite_imageI finite_subset[OF _ S_finite]) auto
next
fix s assume "s ∈ N" then show "x s ≤ ?n s"
by (auto simp: N_def solution_S2 solution_n0)
next
fix s assume s: "s ∈ S - N"
then show "integrable (sc s) x" "integrable (sc s) ?n"
by (auto intro!: integrable_measure_pmf_finite set_pmf_finite sch)
from s have "s ∈ S1" "s ∈ S"
using n_nS12[of s] by (auto simp: N_def)
then have "(∫ t. ?n t ∂sc s) = ?n s"
apply (subst n_sc[symmetric, of s])
apply simp_all
apply (subst integral_eq_nn_integral)
apply (auto simp: Pi_closed[OF sc_Pi] AE_measure_pmf_iff
intro!: arg_cong[where f=enn2real] nn_integral_cong_AE real_n)
done
then show "(∫ t. ?n t ∂sc s) + 0 ≤ ?n s"
by simp
show "x s ≤ (∫ t. x t ∂sc s) + 0"
using solution[OF ‹s ∈ S1› sch[OF ‹s ∈ S›]]
by (subst integral_measure_pmf[where A=S])
(auto intro: S_finite Pi_closed[OF sc_Pi] ‹s ∈ S› simp: ac_simps)
define X where "X = (SIGMA x:UNIV. sc x)"
show "∃t∈N. (s, t) ∈ X⇧*"
proof (rule ccontr)
assume "¬ ?thesis"
then have *: "∀t∈N. (s, t) ∉ X⇧*"
by auto
with ‹s∈S› have "v (simple sc s) = 0"
proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
case (valid t) with sch show ?case
by auto
next
case (nS2 s) then show ?case
by (auto simp: N_def)
next
case (cont cfg s)
then have "(s, state cfg) ∈ X⇧*"
by (auto simp: X_def set_K_cfg)
with cont show ?case
by (auto simp: set_K_cfg intro!: exI intro: Pi_closed[OF sc_Pi])
(blast intro: rtrancl_trans)
qed
from n_eq_0[OF ‹s ∈ S› simple_cfg_on this] have "n s = 0"
by (auto simp: sc_Pi)
with ‹s∈S› have "s∈N"
by (auto simp: N_def)
with * show False
by auto
qed
qed
next
assume "s ∉ S - N" with ‹s ∈ S› show "x s ≤ ?n s"
by (auto simp: N_def solution_n0 solution_S2)
qed
qed
end
end
Theory Discrete_Time_Markov_Process
section ‹Discrete-time Markov Processes›
text ‹In this file we construct discrete-time Markov processes, e.g. with arbitrary state spaces.›
theory Discrete_Time_Markov_Process
imports Markov_Models_Auxiliary
begin
lemma measure_eqI_PiM_sequence:
fixes M :: "nat ⇒ 'a measure"
assumes *[simp]: "sets P = PiM UNIV M" "sets Q = PiM UNIV M"
assumes eq: "⋀A n. (⋀i. A i ∈ sets (M i)) ⟹
P (prod_emb UNIV M {..n} (Pi⇩E {..n} A)) = Q (prod_emb UNIV M {..n} (Pi⇩E {..n} A))"
assumes A: "finite_measure P"
shows "P = Q"
proof (rule measure_eqI_PiM_infinite[OF * _ A])
fix J :: "nat set" and F'
assume J: "finite J" "⋀i. i ∈ J ⟹ F' i ∈ sets (M i)"
define n where "n = (if J = {} then 0 else Max J)"
define F where "F i = (if i ∈ J then F' i else space (M i))" for i
then have F[simp, measurable]: "F i ∈ sets (M i)" for i
using J by auto
have emb_eq: "prod_emb UNIV M J (Pi⇩E J F') = prod_emb UNIV M {..n} (Pi⇩E {..n} F)"
proof cases
assume "J = {}" then show ?thesis
by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
next
assume "J ≠ {}" then show ?thesis
by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le ‹finite J› split: if_split_asm)
qed
show "emeasure P (prod_emb UNIV M J (Pi⇩E J F')) = emeasure Q (prod_emb UNIV M J (Pi⇩E J F'))"
unfolding emb_eq by (rule eq) fact
qed
lemma distr_cong_simp:
"M = K ⟹ sets N = sets L ⟹ (⋀x. x ∈ space M =simp=> f x = g x) ⟹ distr M N f = distr K L g"
unfolding simp_implies_def by (rule distr_cong)
subsection ‹Constructing Discrete-Time Markov Processes›
locale discrete_Markov_process =
fixes M :: "'a measure" and K :: "'a ⇒ 'a measure"
assumes K[measurable]: "K ∈ M →⇩M prob_algebra M"
begin
lemma space_K: "x ∈ space M ⟹ space (K x) = space M"
using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
by (auto dest: subprob_measurableD)
lemma sets_K[measurable_cong]: "x ∈ space M ⟹ sets (K x) = sets M"
using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
by (auto dest: subprob_measurableD)
lemma prob_space_K: "x ∈ space M ⟹ prob_space (K x)"
using measurable_space[OF K] by (simp add: space_prob_algebra)
definition K' :: "'a ⇒ nat ⇒ (nat ⇒ 'a) ⇒ 'a measure"
where
"K' x n' ω' = K (case_nat x ω' n')"
lemma IT_K':
assumes x: "x ∈ space M" shows "Ionescu_Tulcea (K' x) (λ_. M)"
unfolding Ionescu_Tulcea_def K'_def[abs_def]
proof safe
fix i show "(λω'. K (case i of 0 ⇒ x | Suc x ⇒ ω' x)) ∈ Pi⇩M {0..<i} (λ_. M) →⇩M subprob_algebra M"
using x by (intro measurable_prob_algebraD measurable_compose[OF _ K]) measurable
next
fix i :: nat and ω assume ω: "ω ∈ space (Pi⇩M {0..<i} (λ_. M))"
with x have "(case i of 0 ⇒ x | Suc x ⇒ ω x) ∈ space M"
by (auto simp: space_PiM split: nat.split)
then show "prob_space (K (case i of 0 ⇒ x | Suc x ⇒ ω x))"
using K unfolding measurable_restrict_space2_iff prob_algebra_def by auto
qed
definition lim_sequence :: "'a ⇒ (nat ⇒ 'a) measure"
where
"lim_sequence x = projective_family.lim UNIV (Ionescu_Tulcea.CI (K' x) (λ_. M)) (λ_. M)"
lemma
assumes x: "x ∈ space M"
shows space_lim_sequence: "space (lim_sequence x) = space (Π⇩M i∈UNIV. M)"
and sets_lim_sequence[measurable_cong]: "sets (lim_sequence x) = sets (Π⇩M i∈UNIV. M)"
and emeasure_lim_sequence_emb: "⋀J X. finite J ⟹ X ∈ sets (Π⇩M j∈J. M) ⟹
emeasure (lim_sequence x) (prod_emb UNIV (λ_. M) J X) =
emeasure (Ionescu_Tulcea.CI (K' x) (λ_. M) J) X"
and emeasure_lim_sequence_emb_I0o: "⋀n X. X ∈ sets (Π⇩M i ∈ {0..<n}. M) ⟹
emeasure (lim_sequence x) (prod_emb UNIV (λ_. M) {0..<n} X) =
emeasure (Ionescu_Tulcea.C (K' x) (λ_. M) 0 n (λx. undefined)) X"
proof -
interpret Ionescu_Tulcea "K' x" "λ_. M"
using x by (rule IT_K')
show "space (lim_sequence x) = space (Π⇩M i∈UNIV. M)"
unfolding lim_sequence_def by simp
show "sets (lim_sequence x) = sets (Π⇩M i∈UNIV. M)"
unfolding lim_sequence_def by simp
{ fix J :: "nat set" and X assume "finite J" "X ∈ sets (Π⇩M j∈J. M)"
then show "emeasure (lim_sequence x) (PF.emb UNIV J X) = emeasure (CI J) X"
unfolding lim_sequence_def by (rule lim) }
note emb = this
have up_to_I0o[simp]: "up_to {0..<n} = n" for n
unfolding up_to_def by (rule Least_equality) auto
{ fix n :: nat and X assume "X ∈ sets (Π⇩M j∈{0..<n}. M)"
then show "emeasure (lim_sequence x) (PF.emb UNIV {0..<n} X) = emeasure (C 0 n (λx. undefined)) X"
by (simp add: space_C emb CI_def space_PiM distr_id2 sets_C cong: distr_cong_simp) }
qed
lemma lim_sequence[measurable]: "lim_sequence ∈ M →⇩M prob_algebra (Π⇩M i∈UNIV. M)"
proof (intro measurable_prob_algebra_generated[OF sets_PiM Int_stable_prod_algebra prod_algebra_sets_into_space])
fix a assume [simp]: "a ∈ space M"
interpret Ionescu_Tulcea "K' a" "λ_. M"
by (rule IT_K') simp
have sp: "space (lim_sequence a) = prod_emb UNIV (λ_. M) {} (Π⇩E j∈{}. space M)" "space (CI {}) = {} →⇩E space M"
by (auto simp: space_lim_sequence space_PiM prod_emb_def PF.space_P)
show "prob_space (lim_sequence a)"
apply standard
using PF.prob_space_P[THEN prob_space.emeasure_space_1, of "{}"]
apply (simp add: sp emeasure_lim_sequence_emb del: PiE_empty_domain)
done
show "sets (lim_sequence a) = sets (Pi⇩M UNIV (λi. M))"
by (simp add: sets_lim_sequence)
next
fix X :: "(nat ⇒ 'a) set" assume "X ∈ prod_algebra UNIV (λi. M)"
then obtain J :: "nat set" and F where J: "J ≠ {}" "finite J" "F ∈ J → sets M"
and X: "X = prod_emb UNIV (λ_. M) J (Pi⇩E J F)"
unfolding prod_algebra_def by auto
then have Pi_F: "finite J" "Pi⇩E J F ∈ sets (Pi⇩M J (λ_. M))"
by (auto intro: sets_PiM_I_finite)
define n where "n = (LEAST n. ∀i≥n. i ∉ J)"
have J_le_n: "J ⊆ {0..<n}"
unfolding n_def
using ‹finite J›
apply -
apply (rule LeastI2[of _ "Suc (Max J)"])
apply (auto simp: Suc_le_eq not_le[symmetric])
done
have C: "(λx. Ionescu_Tulcea.C (K' x) (λ_. M) 0 n (λx. undefined)) ∈ M →⇩M subprob_algebra (Pi⇩M {0..<n} (λ_. M))"
apply (induction n)
apply (subst measurable_cong)
apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
apply assumption
apply (rule measurable_compose[OF _ return_measurable])
apply simp
apply (subst measurable_cong)
apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
apply assumption
apply (rule measurable_bind')
apply assumption
apply (subst measurable_cong)
proof -
fix n :: nat and w assume "w ∈ space (M ⨂⇩M Pi⇩M {0..<n} (λ_. M))"
then show "(case w of (x, xa) ⇒ Ionescu_Tulcea.eP (K' x) (λ_. M) (0 + n) xa) =
(case w of (x, xa) ⇒ distr (K' x n xa) (Π⇩M i∈{0..<Suc n}. M) (fun_upd xa n))"
by (auto simp: space_pair_measure Ionescu_Tulcea.eP_def[OF IT_K'] split: prod.split)
next
fix n show "(λw. case w of (x, xa) ⇒ distr (K' x n xa) (Pi⇩M {0..<Suc n} (λi. M)) (fun_upd xa n))
∈ M ⨂⇩M Pi⇩M {0..<n} (λ_. M) →⇩M subprob_algebra (Pi⇩M {0..<Suc n} (λ_. M))"
unfolding K'_def
apply measurable
apply (rule measurable_distr2[where M=M])
apply (rule measurable_PiM_single')
apply (simp add: split_beta')
subgoal for i by (cases "i = n") auto
subgoal by (auto simp: split_beta' PiE_iff extensional_def Pi_iff space_pair_measure space_PiM)
apply (rule measurable_prob_algebraD)
apply (rule measurable_compose[OF _ K])
apply measurable
done
qed
have "(λa. emeasure (lim_sequence a) X) ∈ borel_measurable M ⟷
(λa. emeasure (Ionescu_Tulcea.CI (K' a) (λ_. M) J) (Pi⇩E J F)) ∈ borel_measurable M"
unfolding X using J Pi_F by (intro measurable_cong emeasure_lim_sequence_emb) auto
also have "…"
apply (intro measurable_compose[OF _ measurable_emeasure_subprob_algebra[OF Pi_F(2)]])
apply (subst measurable_cong)
apply (subst Ionescu_Tulcea.CI_def[OF IT_K'])
apply assumption
apply (subst Ionescu_Tulcea.up_to_def[OF IT_K'])
apply assumption
unfolding n_def[symmetric]
apply (rule refl)
apply (rule measurable_compose[OF _ measurable_distr[OF measurable_restrict_subset[OF J_le_n]]])
apply (rule C)
done
finally show "(λa. emeasure (lim_sequence a) X) ∈ borel_measurable M" .
qed
lemma step_C:
assumes x: "x ∈ space M"
shows "Ionescu_Tulcea.C (K' x) (λ_. M) 0 1 (λ_. undefined) ⤜ Ionescu_Tulcea.C (K' x) (λ_. M) 1 n =
K x ⤜ (λy. Ionescu_Tulcea.C (K' x) (λ_. M) 1 n (case_nat y (λ_. undefined)))"
proof -
interpret Ionescu_Tulcea "K' x" "λ_. M"
using x by (rule IT_K')
have [simp]: "space (K x) ≠ {}"
using space_K[OF x] x by auto
have [simp]: "((λ_. undefined::'a)(0 := x)) = case_nat x (λ_. undefined)" for x
by (auto simp: fun_eq_iff split: nat.split)
have "C 0 1 (λ_. undefined) ⤜ C 1 n = eP 0 (λ_. undefined) ⤜ C 1 n"
using measurable_eP[of 0] measurable_C[of 1 n, measurable del]
by (simp add: bind_return[where N="Pi⇩M {0} (λ_. M)"])
also have "… = K x ⤜ (λy. C 1 n (case_nat y (λ_. undefined)))"
using measurable_C[of 1 n, measurable del] x[THEN sets_K]
by (simp add: eP_def K'_def bind_distr cong: measurable_cong_sets)
finally show "C 0 1 (λ_. undefined) ⤜ C 1 n = K x ⤜ (λy. C 1 n (case_nat y (λ_. undefined)))" .
qed
lemma lim_sequence_eq:
assumes x: "x ∈ space M"
shows "lim_sequence x = bind (K x) (λy. distr (lim_sequence y) (Π⇩M j∈UNIV. M) (case_nat y))"
(is "_ = ?B x")
proof (rule measure_eqI_PiM_infinite)
show "sets (lim_sequence x) = sets (Π⇩M j∈UNIV. M)"
using x by (rule sets_lim_sequence)
have [simp]: "space (K x) ≠ {}"
using space_K[OF x] x by auto
show "sets (?B x) = sets (Pi⇩M UNIV (λj. M))"
using x by (subst sets_bind) auto
interpret lim_sequence: prob_space "lim_sequence x"
using lim_sequence x by (auto simp: measurable_restrict_space2_iff prob_algebra_def)
show "finite_measure (lim_sequence x)"
by (rule lim_sequence.finite_measure)
interpret Ionescu_Tulcea "K' x" "λ_. M"
using x by (rule IT_K')
let ?U = "λ_::nat. undefined :: 'a"
fix J :: "nat set" and F'
assume J: "finite J" "⋀i. i ∈ J ⟹ F' i ∈ sets M"
define n where "n = (if J = {} then 0 else Max J)"
define F where "F i = (if i ∈ J then F' i else space M)" for i
then have F[simp, measurable]: "F i ∈ sets M" for i
using J by auto
have emb_eq: "PF.emb UNIV J (Pi⇩E J F') = PF.emb UNIV {0..<Suc n} (Pi⇩E {0..<Suc n} F)"
proof cases
assume "J = {}" then show ?thesis
by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
next
assume "J ≠ {}" then show ?thesis
by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le ‹finite J› split: if_split_asm)
qed
have "emeasure (lim_sequence x) (PF.emb UNIV J (Pi⇩E J F')) = emeasure (C 0 (Suc n) ?U) (Pi⇩E {0..<Suc n} F)"
using x unfolding emb_eq by (rule emeasure_lim_sequence_emb_I0o) (auto intro!: sets_PiM_I_finite)
also have "C 0 (Suc n) ?U = K x ⤜ (λy. C 1 n (case_nat y ?U))"
using split_C[of ?U 0 "Suc 0" n] step_C[OF x] by simp
also have "emeasure (K x ⤜ (λy. C 1 n (case_nat y ?U))) (Pi⇩E {0..<Suc n} F) =
(∫⇧+y. C 1 n (case_nat y ?U) (Pi⇩E {0..<Suc n} F) ∂K x)"
using measurable_C[of 1 n, measurable del] x[THEN sets_K] F x
by (intro emeasure_bind[OF _ measurable_compose[OF _ measurable_C]])
(auto cong: measurable_cong_sets intro!: measurable_PiM_single' split: nat.split_asm)
also have "… = (∫⇧+y. distr (lim_sequence y) (Pi⇩M UNIV (λj. M)) (case_nat y) (PF.emb UNIV J (Pi⇩E J F')) ∂K x)"
proof (intro nn_integral_cong)
fix y assume "y ∈ space (K x)"
then have y: "y ∈ space M"
using x by (simp add: space_K)
then interpret y: Ionescu_Tulcea "K' y" "λ_. M"
by (rule IT_K')
let ?y = "case_nat y"
have [simp]: "?y ?U ∈ space (Pi⇩M {0} (λi. M))"
using y by (auto simp: space_PiM PiE_iff extensional_def split: nat.split)
have yM[measurable]: "?y ∈ Pi⇩M {0..<m} (λ_. M) →⇩M Pi⇩M {0..<Suc m} (λi. M)" for m
using y by (intro measurable_PiM_single') (auto simp: space_PiM PiE_iff extensional_def split: nat.split)
have y': "?y ?U ∈ space (Pi⇩M {0..<1} (λi. M))"
by (simp add: space_PiM PiE_def y extensional_def split: nat.split)
have eq1: "?y -` Pi⇩E {0..<Suc n} F ∩ space (Pi⇩M {0..<n} (λ_. M)) =
(if y ∈ F 0 then Pi⇩E {0..<n} (F∘Suc) else {})"
unfolding set_eq_iff using y sets.sets_into_space[OF F]
by (auto simp: space_PiM PiE_iff extensional_def Ball_def split: nat.split nat.split_asm)
have eq2: "?y -` PF.emb UNIV {0..<Suc n} (Pi⇩E {0..<Suc n} F) ∩ space (Pi⇩M UNIV (λ_. M)) =
(if y ∈ F 0 then PF.emb UNIV {0..<n} (Pi⇩E {0..<n} (F∘Suc)) else {})"
unfolding set_eq_iff using y sets.sets_into_space[OF F]
by (auto simp: space_PiM PiE_iff prod_emb_def extensional_def Ball_def split: nat.split nat.split_asm)
let ?I = "indicator (F 0) y"
have "C 1 n (?y ?U) = distr (y.C 0 n ?U) (Π⇩M i∈{0..<Suc n}. M) ?y"
proof (induction n)
case (Suc m)
have "C 1 (Suc m) (?y ?U) = distr (y.C 0 m ?U) (Pi⇩M {0..<Suc m} (λi. M)) ?y ⤜ eP (Suc m)"
using Suc by simp
also have "… = y.C 0 m ?U ⤜ (λx. eP (Suc m) (?y x))"
by (intro bind_distr[where K="Pi⇩M {0..<Suc (Suc m)} (λ_. M)"]) (simp_all add: y y.space_C y.sets_C cong: measurable_cong_sets)
also have "… = y.C 0 m ?U ⤜ (λx. distr (y.eP m x) (Pi⇩M {0..<Suc (Suc m)} (λi. M)) ?y)"
proof (intro bind_cong refl)
fix ω' assume ω': "ω' ∈ space (y.C 0 m ?U)"
moreover have "K' x (Suc m) (?y ω') = K' y m ω'"
by (auto simp: K'_def)
ultimately show "eP (Suc m) (?y ω') = distr (y.eP m ω') (Pi⇩M {0..<Suc (Suc m)} (λi. M)) ?y"
unfolding eP_def y.eP_def
by (subst distr_distr)
(auto simp: y.space_C y.sets_P split: nat.split cong: measurable_cong_sets
intro!: distr_cong measurable_fun_upd[where J="{0..<m}"])
qed
also have "… = distr (y.C 0 m ?U ⤜ y.eP m) (Pi⇩M {0..<Suc (Suc m)} (λi. M)) ?y"
by (intro distr_bind[symmetric, OF _ _ yM]) (auto simp: y.space_C y.sets_C cong: measurable_cong_sets)
finally show ?case
by simp
qed (use y in ‹simp add: PiM_empty distr_return›)
then have "C 1 n (case_nat y ?U) (Pi⇩E {0..<Suc n} F) =
(distr (y.C 0 n ?U) (Π⇩M i∈{0..<Suc n}. M) ?y) (Pi⇩E {0..<Suc n} F)" by simp
also have "… = ?I * y.C 0 n ?U (Pi⇩E {0..<n} (F ∘ Suc))"
by (subst emeasure_distr) (auto simp: y.sets_C y.space_C eq1 cong: measurable_cong_sets)
also have "… = ?I * lim_sequence y (PF.emb UNIV {0..<n} (Pi⇩E {0..<n} (F ∘ Suc)))"
using y by (simp add: emeasure_lim_sequence_emb_I0o sets_PiM_I_finite)
also have "… = distr (lim_sequence y) (Pi⇩M UNIV (λj. M)) ?y (PF.emb UNIV {0..<Suc n} (Pi⇩E {0..<Suc n} F))"
using y by (subst emeasure_distr) (simp_all add: eq2 space_lim_sequence)
finally show "emeasure (C 1 n (case_nat y (λ_. undefined))) (Pi⇩E {0..<Suc n} F) =
emeasure (distr (lim_sequence y) (Pi⇩M UNIV (λj. M)) (case_nat y)) (PF.emb UNIV J (Pi⇩E J F'))"
unfolding emb_eq .
qed
also have "… =
emeasure (K x ⤜ (λy. distr (lim_sequence y) (Pi⇩M UNIV (λj. M)) (case_nat y))) (PF.emb UNIV J (Pi⇩E J F'))"
using J
by (subst emeasure_bind[where N="PiM UNIV (λ_. M)"])
(auto simp: sets_K x intro!: measurable_distr2[OF _ measurable_prob_algebraD[OF lim_sequence]] cong: measurable_cong_sets)
finally show "emeasure (lim_sequence x) (PF.emb UNIV J (Pi⇩E J F')) =
emeasure (K x ⤜ (λy. distr (lim_sequence y) (Pi⇩M UNIV (λj. M)) (case_nat y)))
(PF.emb UNIV J (Pi⇩E J F'))" .
qed
lemma AE_lim_sequence:
assumes x[simp]: "x ∈ space M" and P[measurable]: "Measurable.pred (Π⇩M i∈UNIV. M) P"
shows "(AE ω in lim_sequence x. P ω) ⟷ (AE y in K x. AE ω in lim_sequence y. P (case_nat y ω))"
apply (simp add: lim_sequence_eq cong del: AE_cong)
apply (subst AE_bind)
apply (rule measurable_prob_algebraD)
apply measurable
apply (auto intro!: AE_cong simp add: space_K AE_distr_iff)
done
definition lim_stream :: "'a ⇒ 'a stream measure"
where
"lim_stream x = distr (lim_sequence x) (stream_space M) to_stream"
lemma space_lim_stream: "space (lim_stream x) = streams (space M)"
unfolding lim_stream_def by (simp add: space_stream_space)
lemma sets_lim_stream[measurable_cong]: "sets (lim_stream x) = sets (stream_space M)"
unfolding lim_stream_def by simp
lemma lim_stream[measurable]: "lim_stream ∈ M →⇩M prob_algebra (stream_space M)"
unfolding lim_stream_def[abs_def] by (intro measurable_distr_prob_space2[OF lim_sequence]) auto
lemma space_stream_space_M_ne: "x ∈ space M ⟹ space (stream_space M) ≠ {}"
using sconst_streams[of x "space M"] by (auto simp: space_stream_space)
lemma prob_space_lim_stream: "x ∈ space M ⟹ prob_space (lim_stream x)"
using measurable_space[OF lim_stream, of x] by (simp add: space_prob_algebra)
lemma lim_stream_eq:
assumes x: "x ∈ space M"
shows "lim_stream x = do { y ← K x; ω ← lim_stream y; return (stream_space M) (y ## ω) }"
unfolding lim_stream_def
apply (subst lim_sequence_eq[OF x])
apply (subst distr_bind[OF _ _ measurable_to_stream])
subgoal
by (auto simp: sets_K x cong: measurable_cong_sets
intro!: measurable_prob_algebraD measurable_distr_prob_space2[where M="Pi⇩M UNIV (λj. M)"] lim_sequence) []
subgoal
using x by (auto simp add: space_K)
apply (intro bind_cong refl)
apply (subst distr_distr)
apply (auto simp: space_K sets_lim_sequence x cong: measurable_cong_sets intro!: distr_cong)
apply (subst bind_return_distr')
apply (auto simp: space_stream_space_M_ne)
apply (subst distr_distr)
apply (auto simp: space_K sets_lim_sequence x to_stream_nat_case cong: measurable_cong_sets intro!: distr_cong)
done
lemma AE_lim_stream:
assumes x[simp]: "x ∈ space M" and P[measurable]: "Measurable.pred (stream_space M) P"
shows "(AE ω in lim_stream x. P ω) ⟷ (AE y in K x. AE ω in lim_stream y. P (y ## ω))"
unfolding lim_stream_eq[OF x]
by (simp_all add: space_K space_lim_stream space_stream_space AE_return AE_bind[OF measurable_prob_algebraD P] cong: AE_cong_simp)
lemma emeasure_lim_stream:
assumes x[measurable, simp]: "x ∈ space M" and A[measurable, simp]: "A ∈ sets (stream_space M)"
shows "lim_stream x A = (∫⇧+y. emeasure (lim_stream y) (((##) y) -` A ∩ space (stream_space M)) ∂K x)"
apply (subst lim_stream_eq, simp)
apply (subst emeasure_bind[OF _ _ A], simp add: prob_space.not_empty prob_space_K)
apply (rule measurable_prob_algebraD)
apply measurable
apply (intro nn_integral_cong)
apply (subst bind_return_distr')
apply (auto intro!: prob_space.not_empty prob_space_lim_stream simp: space_K emeasure_distr)
apply (simp add: space_lim_stream space_stream_space)
done
lemma lim_stream_eq_coinduct[case_names in_space step]:
fixes R :: "'a ⇒ 'a stream measure ⇒ bool"
assumes x: "R x B" "x ∈ space M"
assumes R: "⋀x B. R x B ⟹ ∃B'∈M →⇩M prob_algebra (stream_space M).
(AE y in K x. R y (B' y) ∨ lim_stream y = B' y) ∧
B = do { y ← K x; ω ← B' y; return (stream_space M) (y ## ω) }"
shows "lim_stream x = B"
using x
proof (coinduction arbitrary: x B rule: stream_space_coinduct[where M=M, case_names step])
case (step x B)
from R[OF ‹R x B›] obtain B' where B': "B' ∈ M →⇩M prob_algebra (stream_space M)"
and ae: "AE y in K x. R y (B' y) ∨ lim_stream y = B' y"
and eq: "B = K x ⤜ (λy. B' y ⤜ (λω. return (stream_space M) (y ## ω)))"
by blast
show ?case
apply (rule bexI[of _ "K x"], rule bexI[OF _ lim_stream], rule bexI[OF _ B'])
apply (intro conjI)
subgoal
using ae AE_space by eventually_elim (insert ‹x∈space M›, auto simp: space_K)
subgoal
by (rule lim_stream_eq) fact
subgoal
by (rule eq)
subgoal
using K ‹x ∈ space M› by (rule measurable_space)
done
qed
lemma prob_space_lim_sequence: "x ∈ space M ⟹ prob_space (lim_sequence x)"
using measurable_space[OF lim_sequence, of x] by (simp add: space_prob_algebra)
end
subsection ‹Strong Markov Property for Discrete-Time Markov Processes›
text ‹The filtration adopted to streams, i.e. to the $n$-th projection.›
definition stream_filtration :: "'a measure ⇒ enat ⇒ 'a stream measure"
where "stream_filtration M n = (SUP i∈{i::nat. i ≤ n}. vimage_algebra (streams (space M)) (λω . ω !! i) M)"
lemma measurable_stream_filtration1: "enat i ≤ n ⟹ (λω. ω !! i) ∈ stream_filtration M n →⇩M M"
by (auto intro!: measurable_SUP1 measurable_vimage_algebra1 snth_in simp: stream_filtration_def)
lemma measurable_stream_filtration2:
"f ∈ space N → streams (space M) ⟹ (⋀i. enat i ≤ n ⟹ (λx. f x !! i) ∈ N →⇩M M) ⟹ f ∈ N →⇩M stream_filtration M n"
by (auto simp: stream_filtration_def enat_0
intro!: measurable_SUP2 measurable_vimage_algebra2 elim!: allE[of _ "0::nat"])
lemma space_stream_filtration: "space (stream_filtration M n) = space (stream_space M)"
by (auto simp add: space_stream_space space_Sup_eq_UN stream_filtration_def enat_0 elim!: allE[of _ 0])
lemma sets_stream_filteration_le_stream_space: "sets (stream_filtration M n) ⊆ sets (stream_space M)"
unfolding sets_stream_space_eq stream_filtration_def
by (intro SUP_subset_mono le_measureD2) (auto simp: space_Sup_eq_UN enat_0 elim!: allE[of _ 0])
interpretation stream_filtration: filtration "space (stream_space M)" "stream_filtration M"
proof
show "space (stream_filtration M i) = space (stream_space M)" for i
by (simp add: space_stream_filtration)
show "sets (stream_filtration M i) ⊆ sets (stream_filtration M j)" if "i ≤ j" for i j
proof (rule le_measureD2)
show "stream_filtration M i ≤ stream_filtration M j"
using ‹i ≤ j› unfolding stream_filtration_def by (intro SUP_subset_mono) auto
qed (simp add: space_stream_filtration)
qed
lemma measurable_stopping_time_stream:
"stopping_time (stream_filtration M) T ⟹ T ∈ stream_space M →⇩M count_space UNIV"
using sets_stream_filteration_le_stream_space
by (subst measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric, where 'a=enat]])
(auto intro!: measurable_stopping_time simp: space_stream_filtration)
lemma measurable_stopping_time_All_eq_0:
assumes T: "stopping_time (stream_filtration M) T"
shows "{x∈space M. ∀ω∈streams (space M). T (x ## ω) = 0} ∈ sets M"
proof -
have "{ω∈streams (space M). T ω = 0} ∈ vimage_algebra (streams (space M)) (λω. ω !! 0) M"
using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
then obtain A
where A: "A ∈ sets M"
and *: "{ω ∈ streams (space M). T ω = 0} = (λω. ω !! 0) -` A ∩ streams (space M)"
by (auto simp: sets_vimage_algebra2 streams_shd)
have "A = {x∈space M. ∀ω∈streams (space M). T (x ## ω) = 0}"
proof safe
fix x ω assume "x ∈ A" "ω ∈ streams (space M)"
then have "x ## ω ∈ {ω ∈ streams (space M). T ω = 0}"
unfolding * using A[THEN sets.sets_into_space] by auto
then show "T (x ## ω) = 0" by auto
next
fix x assume "x ∈ space M" "∀ω∈streams (space M). T (x ## ω) = 0 "
then have "∀ω∈streams (space M). x ## ω ∈ {ω ∈ streams (space M). T ω = 0}"
by simp
with ‹x∈space M› show "x ∈ A"
unfolding * by (auto simp: streams_empty_iff)
qed (use A[THEN sets.sets_into_space] in auto)
with ‹A ∈ sets M› show ?thesis by auto
qed
lemma stopping_time_0:
assumes T: "stopping_time (stream_filtration M) T"
and x: "x ∈ space M" and ω: "ω ∈ streams (space M)" "T (x ## ω) > 0"
and ω': "ω' ∈ streams (space M)"
shows "T (x ## ω') > 0"
unfolding zero_less_iff_neq_zero
proof
assume "T (x ## ω') = 0"
with x ω' have x': "x ## ω' ∈ {ω ∈ streams (space M). T ω = 0}"
by auto
have "{ω∈streams (space M). T ω = 0} ∈ vimage_algebra (streams (space M)) (λω. ω !! 0) M"
using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
then obtain A
where A: "A ∈ sets M"
and *: "{ω ∈ streams (space M). T ω = 0} = (λω. ω !! 0) -` A ∩ streams (space M)"
by (auto simp: sets_vimage_algebra2 streams_shd)
with x' have "x ∈ A"
by auto
with ω x have "x ## ω ∈ (λω. ω !! 0) -` A ∩ streams (space M)"
by auto
with ω show False
unfolding *[symmetric] by auto
qed
lemma stopping_time_epred_SCons:
assumes T: "stopping_time (stream_filtration M) T"
and x: "x ∈ space M" and ω: "ω ∈ streams (space M)" "T (x ## ω) > 0"
shows "stopping_time (stream_filtration M) (λω. epred (T (x ## ω)))"
proof (rule stopping_timeI, rule measurable_cong[THEN iffD2])
show "ω ∈ space (stream_filtration M t) ⟹ (epred (T (x ## ω)) ≤ t) = (T (x ## ω) ≤ eSuc t)" for t ω
by (cases "T (x ## ω)" rule: enat_coexhaust)
(auto simp add: space_stream_filtration space_stream_space dest!: stopping_time_0[OF T x ω])
show "Measurable.pred (stream_filtration M t) (λw. T (x ## w) ≤ eSuc t)" for t
proof (rule measurable_compose[of "SCons x"])
show "(##) x ∈ stream_filtration M t →⇩M stream_filtration M (eSuc t)"
proof (intro measurable_stream_filtration2)
show "enat i ≤ eSuc t ⟹ (λxa. (x ## xa) !! i) ∈ stream_filtration M t →⇩M M" for i
using ‹x∈space M›
by (cases i) (auto simp: eSuc_enat[symmetric] intro!: measurable_stream_filtration1)
qed (auto simp: space_stream_filtration space_stream_space ‹x∈space M›)
qed (rule T[THEN stopping_timeD])
qed
context discrete_Markov_process
begin
lemma lim_stream_strong_Markov:
assumes x: "x ∈ space M" and T: "stopping_time (stream_filtration M) T"
shows "lim_stream x =
lim_stream x ⤜ (λω. case T ω of
enat i ⇒ distr (lim_stream (ω !! i)) (stream_space M) (λω'. stake (Suc i) ω @- ω')
| ∞ ⇒ return (stream_space M) ω)"
(is "_ = ?L T x")
using assms
proof (coinduction arbitrary: x T rule: lim_stream_eq_coinduct)
case (step x T)
note T = ‹stopping_time (stream_filtration M) T›[THEN measurable_stopping_time_stream, measurable]
define L where "L T x = ?L T x" for T x
have L[measurable (raw)]:
"(λ(x, ω). T x ω) ∈ N ⨂⇩M stream_space M →⇩M count_space UNIV ⟹
f ∈ N →⇩M M ⟹ (λx. L (T x) (f x)) ∈ N →⇩M prob_algebra (stream_space M)" for f :: "'a ⇒ 'a" and N T
unfolding L_def
by (intro measurable_bind_prob_space2[OF measurable_compose[OF _ lim_stream]] measurable_case_enat
measurable_distr_prob_space2[OF measurable_compose[OF _ lim_stream]]
measurable_return_prob_space measurable_stopping_time_stream)
auto
define S where "S x = (if ∀ω∈streams (space M). T (x##ω) = 0 then lim_stream x else L (λω. epred (T (x ## ω))) x)" for x
then have S_eq: "∀ω∈streams (space M). T (x##ω) = 0 ⟹ S x = lim_stream x"
"¬ (∀ω∈streams (space M). T (x##ω) = 0) ⟹ S x = L (λω. epred (T (x ## ω))) x" for x
by auto
have [measurable]: "S ∈ M →⇩M prob_algebra (stream_space M)"
unfolding S_def[abs_def]
by (subst measurable_If_restrict_space_iff, safe intro!: L)
(auto intro!: measurable_stopping_time_All_eq_0 step measurable_restrict_space1 lim_stream
measurable_compose[OF _ measurable_epred] measurable_compose[OF _ T]
measurable_Stream measurable_compose[OF measurable_fst]
simp: measurable_split_conv)
show ?case
unfolding L_def[symmetric]
proof (intro bexI[of _ S] conjI AE_I2)
fix y assume "y ∈ space (K x)"
then show "(∃x T. y = x ∧ S y = L T x ∧ x ∈ space M ∧ stopping_time (stream_filtration M) T) ∨
lim_stream y = S y"
using ‹x∈space M›
by (cases "∀ω∈streams (space M). T (y##ω) = 0")
(auto simp add: S_eq space_K intro!: exI[of _ "λω. epred (T (y ## ω))"] stopping_time_epred_SCons step)
next
note ‹x∈space M›[simp]
have "L T x = K x ⤜
(λy. lim_stream y ⤜ (λω. case T (y##ω) of
enat i ⇒ distr (lim_stream ((y##ω) !! i)) (stream_space M) (λω'. stake (Suc i) (y##ω) @- ω')
| ∞ ⇒ return (stream_space M) (y##ω)))" (is "_ = K x ⤜ ?L'")
unfolding L_def
apply (subst lim_stream_eq[OF ‹x∈space M›])
apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
measurable)
apply (rule bind_cong[OF refl])
apply (simp add: space_K)
apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
measurable)
apply (rule bind_cong[OF refl])
apply (simp add: space_lim_stream)
apply (subst bind_return[where N="stream_space M", OF measurable_prob_algebraD])
apply (measurable; fail) []
apply (simp add: space_stream_space)
apply rule
done
also have "… = K x ⤜ (λy. S y ⤜ (λω. return (stream_space M) (y ## ω)))"
proof (intro bind_cong[of "K x"] refl)
fix y assume "y ∈ space (K x)"
then have [simp]: "y ∈ space M"
by (simp add: space_K)
show "?L' y = S y ⤜ (λω. return (stream_space M) (y ## ω))"
proof cases
assume "∀ω∈streams (space M). T (y##ω) = 0"
with x show ?thesis
by (auto simp: S_eq space_lim_stream shift.simps[abs_def] streams_empty_iff
bind_const'[OF _ prob_space_imp_subprob_space] prob_space_lim_stream prob_space.prob_space_distr
intro!: bind_return_distr'[symmetric]
cong: bind_cong_simp)
next
assume *: "¬ (∀ω∈streams (space M). T (y##ω) = 0)"
then have T_pos: "ω ∈ streams (space M) ⟹ T (y ## ω) ≠ 0" for ω
using stopping_time_0[OF ‹stopping_time (stream_filtration M) T›, of y _ ω] by auto
show ?thesis
apply (simp add: S_eq(2)[OF *] L_def)
apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
measurable)
apply (intro bind_cong refl)
apply (auto simp: T_pos enat_0 space_lim_stream shift.simps[abs_def] diff_Suc space_stream_space
intro!: bind_return[where N="stream_space M", OF measurable_prob_algebraD, symmetric]
bind_distr_return[symmetric]
split: nat.split enat.split)
done
qed
qed
finally show "L T x = K x ⤜ (λy. S y ⤜ (λω. return (stream_space M) (y ## ω)))" .
qed fact
qed fact
end
end
Theory Continuous_Time_Markov_Chain
section ‹Continuous-time Markov chains›
theory Continuous_Time_Markov_Chain
imports Discrete_Time_Markov_Process Discrete_Time_Markov_Chain
begin
subsection ‹Trace Operations: relate @{typ "('a × real) stream"} and @{typ "real ⇒ 'a"}›
partial_function (tailrec) trace_at :: "'a ⇒ (real × 'a) stream ⇒ real ⇒ 'a"
where
"trace_at s ω j = (case ω of (t', s')##ω ⇒ if t' ≤ j then trace_at s' ω j else s)"
lemma trace_at_simp[simp]: "trace_at s ((t', s')##ω) j = (if t' ≤ j then trace_at s' ω j else s)"
by (subst trace_at.simps) simp
lemma trace_at_eq:
"trace_at s ω j = (case sfirst (λx. j < fst (shd x)) ω of ∞ ⇒ undefined | enat i ⇒ (s ## smap snd ω) !! i)"
proof (split enat.split; safe)
assume "sfirst (λx. j < fst (shd x)) ω = ∞"
with sfirst_finite[of "λx. j < fst (shd x)" ω]
have "alw (λx. fst (shd x) ≤ j) ω"
by (simp add: not_ev_iff not_less)
then show "trace_at s ω j = undefined"
by (induction arbitrary: s ω rule: trace_at.fixp_induct) (auto split: stream.split)
next
show "sfirst (λx. j < fst (shd x)) ω = enat n ⟹ trace_at s ω j = (s ## smap snd ω) !! n" for n
proof (induction n arbitrary: s ω)
case 0 then show ?case
by (subst trace_at.simps) (auto simp add: enat_0 sfirst_eq_0 split: stream.split)
next
case (Suc n) show ?case
using sfirst.simps[of "λx. j < fst (shd x)" ω] Suc.prems Suc.IH[of "stl ω" "snd (shd ω)"]
by (cases ω) (auto simp add: eSuc_enat[symmetric] split: stream.split if_split_asm)
qed
qed
lemma trace_at_shift: "trace_at s (smap (λ(t, s'). (t + t', s')) ω) t = trace_at s ω (t - t')"
by (induction arbitrary: s ω rule: trace_at.fixp_induct) (auto split: stream.split)
primcorec merge_at :: "(real × 'a) stream ⇒ real ⇒ (real × 'a) stream ⇒ (real × 'a) stream"
where
"merge_at ω j ω' = (case ω of (t, s) ## ω ⇒ if t ≤ j then (t, s)##merge_at ω j ω' else ω')"
lemma merge_at_simp[simp]: "merge_at (x##ω) j ω' = (if fst x ≤ j then x##merge_at ω j ω' else ω')"
by (cases x) (subst merge_at.code; simp)
subsection ‹Exponential Distribution›
definition exponential :: "real ⇒ real measure"
where
"exponential l = density lborel (exponential_density l)"
lemma space_exponential: "space (exponential l) = UNIV"
by (simp add: exponential_def)
lemma sets_exponential[measurable_cong]: "sets (exponential l) = sets borel"
by (simp add: exponential_def)
lemma prob_space_exponential: "0 < l ⟹ prob_space (exponential l)"
unfolding exponential_def by (intro prob_space_exponential_density)
lemma AE_exponential: "0 < l ⟹ AE x in exponential l. 0 < x"
unfolding exponential_def using AE_lborel_singleton[of 0] by (auto simp add: AE_density exponential_density_def)
lemma emeasure_exponential_Ioi_cutoff:
assumes "0 < l"
shows "emeasure (exponential l) {x <..} = exp (- (max 0 x) * l)"
proof -
interpret prob_space "exponential l"
unfolding exponential_def using ‹0<l› by (rule prob_space_exponential_density)
have *: "prob {xa ∈ space (exponential l). max 0 x < xa} = exp (- max 0 x * l)"
apply (rule exponential_distributedD_gt[OF _ _ ‹0<l›])
apply (auto simp: exponential_def distributed_def)
apply (subst (6) distr_id[symmetric])
apply (subst (2) distr_cong)
apply simp_all
done
have "emeasure (exponential l) {x <..} = emeasure (exponential l) {max 0 x <..}"
using AE_exponential[OF ‹0<l›] by (intro emeasure_eq_AE) auto
also have "… = exp (- (max 0 x) * l)"
using * unfolding emeasure_eq_measure by (simp add: space_exponential greaterThan_def)
finally show ?thesis .
qed
lemma emeasure_exponential_Ioi:
"0 < l ⟹ 0 ≤ x ⟹ emeasure (exponential l) {x <..} = exp (- x * l)"
using emeasure_exponential_Ioi_cutoff[of l x] by simp
lemma exponential_eq_stretch:
assumes "0 < l"
shows "exponential l = distr (exponential 1) borel (λx. (1/l) * x)"
proof (intro measure_eqI)
fix A assume "A ∈ sets (exponential l)"
then have [measurable]: "A ∈ sets borel"
by (simp add: sets_exponential)
then have [measurable]: "(λx. x / l) -` A ∈ sets borel"
by (rule measurable_sets_borel[rotated]) simp
have "emeasure (exponential l) A =
(∫⇧+x. ennreal l * (indicator (((*) (1/l) -` A) ∩ {0 ..}) (l * x) * ennreal (exp (- (l * x)))) ∂lborel)"
using ‹0 < l›
by (auto simp: ac_simps emeasure_distr exponential_def emeasure_density exponential_density_def
ennreal_mult zero_le_mult_iff
intro!: nn_integral_cong split: split_indicator)
also have "… = (∫⇧+x. indicator (((*) (1/l) -` A) ∩ {0 ..}) x * ennreal (exp (- x)) ∂lborel)"
using ‹0<l›
apply (subst nn_integral_stretch)
apply (auto simp: nn_integral_cmult)
apply (simp add: ennreal_mult[symmetric] mult.assoc[symmetric])
done
also have "… = emeasure (distr (exponential 1) borel (λx. (1/l) * x)) A"
by (auto simp add: emeasure_distr exponential_def emeasure_density exponential_density_def
intro!: nn_integral_cong split: split_indicator)
finally show "emeasure (exponential l) A = emeasure (distr (exponential 1) borel (λx. (1/l) * x)) A" .
qed (simp add: sets_exponential)
lemma uniform_measure_exponential:
assumes "0 < l" "0 ≤ t"
shows "uniform_measure (exponential l) {t <..} = distr (exponential l) borel ((+) t)" (is "?L = ?R")
proof (rule measure_eqI_lessThan)
fix x
have "0 < emeasure (exponential l) {t<..}"
unfolding emeasure_exponential_Ioi[OF assms] by simp
with assms show "?L {x<..} < ∞"
by (simp add: ennreal_divide_eq_top_iff less_top[symmetric] lessThan_Int_lessThan
emeasure_exponential_Ioi)
have *: "((+) t -` {x<..} ∩ space (exponential l)) = {x - t <..}"
by (auto simp: space_exponential)
show "?L {x<..} = ?R {x<..}"
using assms by (simp add: lessThan_Int_lessThan emeasure_exponential_Ioi divide_ennreal
emeasure_distr * emeasure_exponential_Ioi_cutoff exp_diff[symmetric] field_simps split: split_max)
qed (auto simp: sets_exponential)
lemma emeasure_PiM_exponential_Ioi_finite:
assumes "J ⊆ I" "finite J" "⋀i. i ∈ I ⟹ 0 < R i" "0 ≤ x"
shows "emeasure (Π⇩M i∈I. exponential (R i)) (prod_emb I (λi. exponential (R i)) J (Π⇩E j∈J. {x<..})) = exp (- x * (∑i∈J. R i))"
proof (subst emeasure_PiM_emb)
from assms show "(∏i∈J. emeasure (exponential (R i)) {x<..}) = ennreal (exp (- x * sum R J))"
by (subst prod.cong[OF refl emeasure_exponential_Ioi])
(auto simp add: prod_ennreal exp_sum sum_negf[symmetric] sum_distrib_left)
qed (insert assms, auto intro!: prob_space_exponential)
lemma emeasure_PiM_exponential_Ioi_sequence:
assumes R: "summable R" "⋀i. 0 < R i" "0 ≤ x"
shows "emeasure (Π⇩M i∈UNIV. exponential (R i)) (Π i∈UNIV. {x<..}) = exp (- x * suminf R)"
proof -
let ?R = "λi. exponential (R i)" let ?P = "Π⇩M i∈UNIV. ?R i"
let ?N = "λn::nat. prod_emb UNIV ?R {..<n} (Π⇩E i∈{..<n}. {x<..})"
interpret prob_space ?P
by (intro prob_space_PiM prob_space_exponential R)
have "(Π⇩M i∈UNIV. exponential (R i)) (⋂n. ?N n) = (INF n. (Π⇩M i∈UNIV. exponential (R i)) (?N n))"
by (intro INF_emeasure_decseq[symmetric] decseq_emb_PiE) (auto simp: incseq_def)
also have "… = (INF n. ennreal (exp (- x * (∑i<n. R i))))"
using R by (intro INF_cong emeasure_PiM_exponential_Ioi_finite) auto
also have "… = ennreal (exp (- x * (SUP n. (∑i<n. R i))))"
using R
by (subst continuous_at_Sup_antimono[where f="λr. ennreal (exp (- x * r))"])
(auto intro!: bdd_aboveI2[where M="∑i. R i"] sum_le_suminf summable_mult mult_left_mono
continuous_mult continuous_at_ennreal continuous_within_exp[THEN continuous_within_compose3] continuous_minus
simp: less_imp_le antimono_def image_comp)
also have "… = ennreal (exp (- x * (∑i. R i)))"
using R by (subst suminf_eq_SUP_real) (auto simp: less_imp_le)
also have "(⋂n. ?N n) = (Π i∈UNIV. {x<..})"
by (fastforce simp: prod_emb_def Pi_iff PiE_iff space_exponential)
finally show ?thesis
using R by simp
qed
lemma emeasure_PiM_exponential_Ioi_countable:
assumes R: "J ⊆ I" "countable J" "⋀i. i ∈ I ⟹ 0 < R i" "0 ≤ x" and finite: "integrable (count_space J) R"
shows "emeasure (Π⇩M i∈I. exponential (R i)) (prod_emb I (λi. exponential (R i)) J (Π⇩E j∈J. {x<..})) =
exp (- x * (LINT i|count_space J. R i))"
proof cases
assume "finite J" with assms show ?thesis
by (subst emeasure_PiM_exponential_Ioi_finite)
(auto simp: lebesgue_integral_count_space_finite)
next
assume "infinite J"
let ?R = "λi. exponential (R i)" let ?P = "Π⇩M i∈I. ?R i"
define f where "f = from_nat_into J"
have J_eq: "J = range f" and f: "inj f" "f ∈ UNIV → I"
using from_nat_into_inj_infinite[of J] range_from_nat_into[of J] ‹countable J› ‹infinite J› ‹J ⊆ I›
by (auto simp: inj_on_def f_def simp del: range_from_nat_into)
have Bf: "bij_betw f UNIV J"
unfolding J_eq using inj_on_imp_bij_betw[OF f(1)] .
have summable_R: "summable (λi. R (f i))"
using finite unfolding integrable_bij_count_space[OF Bf, symmetric] integrable_count_space_nat_iff
by (rule summable_norm_cancel)
have "emeasure (Π⇩M i∈UNIV. exponential (R (f i))) (Π i∈UNIV. {x<..}) = exp (- x * (∑i. R (f i)))"
using finite assms unfolding J_eq by (intro emeasure_PiM_exponential_Ioi_sequence[OF summable_R]) auto
also have "(Π⇩M i∈UNIV. exponential (R (f i))) = distr ?P (Π⇩M i∈UNIV. exponential (R (f i))) (λω. λi∈UNIV. ω (f i))"
using R by (intro distr_PiM_reindex[symmetric, OF _ f] prob_space_exponential) auto
also have "… (Π i∈UNIV. {x<..}) = ?P ((λω. λi∈UNIV. ω (f i)) -` (Π i∈UNIV. {x<..}) ∩ space ?P)"
using f(2) by (intro emeasure_distr infprod_in_sets) (auto simp: Pi_iff)
also have "(λω. λi∈UNIV. ω (f i)) -` (Π i∈UNIV. {x<..}) ∩ space ?P = prod_emb I ?R J (Π⇩E j∈J. {x<..})"
by (auto simp: prod_emb_def space_PiM space_exponential Pi_iff J_eq)
also have "(∑i. R (f i)) = (LINT i|count_space J. R i)"
using finite
by (subst integral_count_space_nat[symmetric])
(auto simp: integrable_bij_count_space[OF Bf] integral_bij_count_space[OF Bf])
finally show ?thesis .
qed
lemma AE_PiM_exponential_suminf_infty:
fixes R :: "nat ⇒ real"
assumes R: "⋀n. 0 < R n" and finite: "(∑n. ennreal (1 / R n)) = top"
shows "AE ω in Π⇩M n∈UNIV. exponential (R n). (∑n. ereal (ω n)) = ∞"
proof -
let ?P = "Π⇩M n∈UNIV. exponential (R n)"
interpret prob_space "exponential (R n)" for n
by (intro prob_space_exponential R)
interpret product_prob_space "λn. exponential (R n)" UNIV
proof qed
have AE_pos: "AE ω in ?P. ∀i. 0 < ω i"
unfolding AE_all_countable by (intro AE_PiM_component allI prob_space_exponential R AE_exponential) simp
have indep: "indep_vars (λi. borel) (λi x. x i) UNIV"
using PiM_component
apply (subst P.indep_vars_iff_distr_eq_PiM)
apply (auto simp: restrict_UNIV distr_id2)
apply (subst distr_id2)
apply (intro sets_PiM_cong)
apply (auto simp: sets_exponential cong: distr_cong)
done
have [simp]: "0 ≤ x + x * R i ⟷ 0 ≤ x" for x i
using zero_le_mult_iff[of x "1 + R i"] R[of i] by (simp add: field_simps)
have "(∫⇧+ω. eexp (∑n. - ereal (ω n)) ∂?P) = (∫⇧+ω. (INF n. ∏i<n. eexp (- ereal (ω i))) ∂?P)"
proof (intro nn_integral_cong_AE, use AE_pos in eventually_elim)
fix ω :: "nat ⇒ real" assume ω: "∀i. 0 < ω i"
show "eexp (∑n. - ereal (ω n)) = (⨅n. ∏i<n. eexp (- ereal (ω i)))"
proof (rule LIMSEQ_unique[OF _ LIMSEQ_INF])
show "(λi. ∏i<i. eexp (- ereal (ω i))) ⇢ eexp (∑n. - ereal (ω n))"
using ω by (intro eexp_suminf summable_minus_ereal summable_ereal_pos) (auto intro: less_imp_le)
show "decseq (λn. ∏i<n. eexp (- ereal (ω i)))"
using ω by (auto simp: decseq_def intro!: prod_mono3 intro: less_imp_le)
qed
qed
also have "… = (INF n. (∫⇧+ω. (∏i<n. eexp (- ereal (ω i))) ∂?P))"
proof (intro nn_integral_monotone_convergence_INF_AE')
show "AE ω in ?P. (∏i<Suc n. eexp (- ereal (ω i))) ≤ (∏i<n. eexp (- ereal (ω i)))" for n
using AE_pos
proof eventually_elim
case (elim ω)
show ?case
by (rule prod_mono3) (auto simp: elim le_less)
qed
qed (auto simp: less_top[symmetric])
also have "… = (INF n. (∏i<n. (∫⇧+ω. eexp (- ereal (ω i)) ∂?P)))"
proof (intro INF_cong refl indep_vars_nn_integral)
show "indep_vars (λ_. borel) (λi ω. eexp (- ereal (ω i))) {..<n}" for n
proof (rule indep_vars_compose2[of _ _ _ "λi x. eexp(- ereal x)"])
show "indep_vars (λi. borel) (λi x. x i) {..<n}"
by (rule indep_vars_subset[OF indep]) auto
qed auto
qed auto
also have "… = (INF n. (∏i<n. R i * (∫⇧+x. indicator {0 ..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) ∂lborel)))"
by (subst product_nn_integral_component)
(auto simp: field_simps exponential_def nn_integral_density ennreal_mult'[symmetric] ennreal_mult''[symmetric]
exponential_density_def exp_diff exp_minus nn_integral_cmult[symmetric]
intro!: INF_cong prod.cong nn_integral_cong split: split_indicator)
also have "… = (INF n. (∏i<n. ennreal (R i / (1 + R i))))"
proof (intro INF_cong prod.cong refl)
show "R i * (∫⇧+ x. indicator {0..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) ∂lborel) =
ennreal (R i / (1 + R i))" for i
using nn_intergal_power_times_exp_Ici[of 0] ‹0 < R i›
by (subst nn_integral_stretch[where c="1 + R i"])
(auto simp: mult.assoc[symmetric] ennreal_mult''[symmetric] less_imp_le mult.commute)
qed
also have "… = (INF n. ennreal (∏i<n. R i / (1 + R i)))"
using R by (intro INF_cong refl prod_ennreal divide_nonneg_nonneg) (auto simp: less_imp_le)
also have "… = (INF n. ennreal (inverse (∏i<n. (1 + R i) / R i)))"
by (subst prod_inversef[symmetric]) simp_all
also have "… = (INF n. inverse (ennreal (∏i<n. (1 + R i) / R i)))"
using R by (subst inverse_ennreal) (auto intro!: prod_pos divide_pos_pos simp: add_pos_pos)
also have "… = inverse (SUP n. ennreal (∏i<n. (1 + R i) / R i))"
by (subst continuous_at_Sup_antimono [where f = inverse])
(auto simp: antimono_def image_comp intro!: continuous_on_imp_continuous_within[OF continuous_on_inverse_ennreal'])
also have "(SUP n. ennreal (∏i<n. (1 + R i) / R i)) = top"
proof (cases "SUP n. ennreal (∏i<n. (1 + R i) / R i)")
case (real r)
have "(λn. ennreal (∏i<n. (1 + R i) / R i)) ⇢ r"
using R unfolding real(2)[symmetric]
by (intro LIMSEQ_SUP monoI ennreal_leI prod_mono2) (auto intro!: divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le)
then have "(λn. (∏i<n. (1 + R i) / R i)) ⇢ r"
by (rule tendsto_ennrealD)
(use R real in ‹auto intro!: always_eventually prod_nonneg divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le›)
moreover have "(1 + R i) / R i = 1 / R i + 1" for i
using ‹0 < R i› by (auto simp: field_simps)
ultimately have "convergent (λn. ∏i<n. 1 / R i + 1)"
by (auto simp: convergent_def)
then have "summable (λi. 1 / R i)"
using R by (subst summable_iff_convergent_prod) (auto intro: less_imp_le)
moreover have "0 ≤ 1 / R i" for i
using R by (auto simp: less_imp_le)
ultimately show ?thesis
using finite ennreal_suminf_neq_top[of "λi. 1 / R i"] by blast
qed
finally have "(∫⇧+ω. eexp (∑n. - ereal (ω n)) ∂?P) = 0"
by simp
then have "AE ω in ?P. eexp (∑n. - ereal (ω n)) = 0"
by (subst (asm) nn_integral_0_iff_AE) auto
then show ?thesis
using AE_pos
proof eventually_elim
show "(∀i. 0 < ω i) ⟹ eexp (∑n. - ereal (ω n)) = 0 ⟹ (∑n. ereal (ω n)) = ∞" for ω
apply (auto simp del: uminus_ereal.simps simp add: uminus_ereal.simps[symmetric]
intro!: summable_iff_suminf_neq_top intro: less_imp_le)
apply (subst (asm) suminf_minus_ereal)
apply (auto intro!: summable_ereal_pos intro: less_imp_le)
done
qed
qed
subsection ‹Transition Rates›
locale transition_rates =
fixes R :: "'a ⇒ 'a ⇒ real"
assumes R_nonneg[simp]: "⋀x y. 0 ≤ R x y"
assumes R_diagonal_0[simp]: "⋀x. R x x = 0"
assumes finite_weight: "⋀x. (∫⇧+y. R x y ∂count_space UNIV) < ∞"
assumes positive_weight: "⋀x. 0 < (∫⇧+y. R x y ∂count_space UNIV)"
begin
abbreviation S :: "(real × 'a) measure"
where "S ≡ (borel ⨂⇩M count_space UNIV)"
abbreviation T :: "(real × 'a) stream measure"
where "T ≡ stream_space S"
abbreviation I :: "'a ⇒ 'a set"
where "I x ≡ {y. 0 < R x y}"
lemma I_countable: "countable (I x)"
proof -
let ?P = "point_measure UNIV (R x)"
interpret finite_measure ?P
proof
show "emeasure ?P (space ?P) ≠ ∞"
using finite_weight
by (simp add: emeasure_density point_measure_def less_top)
qed
from countable_support emeasure_point_measure_finite2[of "{_}" UNIV "R x"]
show ?thesis
by (simp add: emeasure_eq_measure less_le)
qed
definition escape_rate :: "'a ⇒ real" where
"escape_rate x = ∫y. R x y ∂count_space UNIV"
lemma ennreal_escape_rate: "ennreal (escape_rate x) = (∫⇧+y. R x y ∂count_space UNIV)"
using finite_weight[of x] unfolding escape_rate_def
by (intro nn_integral_eq_integral[symmetric]) (auto simp: integrable_iff_bounded)
lemma escape_rate_pos: "0 < escape_rate x"
using positive_weight unfolding ennreal_escape_rate[symmetric] by simp
lemma nonneg_escape_rate[simp]: "0 ≤ escape_rate x"
using escape_rate_pos[THEN less_imp_le] .
lemma prob_space_exponential_escape_rate: "prob_space (exponential (escape_rate x))"
using escape_rate_pos by (rule prob_space_exponential)
lemma measurable_escape_rate[measurable]: "escape_rate ∈ count_space UNIV →⇩M borel"
by auto
lemma measurable_exponential_escape_rate[measurable]: "(λx. exponential (escape_rate x)) ∈ count_space UNIV →⇩M prob_algebra borel"
by (auto simp: space_prob_algebra sets_exponential prob_space_exponential_escape_rate)
interpretation pmf_as_function .
lift_definition J :: "'a ⇒ 'a pmf" is "λx y. R x y / escape_rate x"
proof safe
show "0 ≤ R x y / escape_rate x" for x y
by (auto intro!: integral_nonneg_AE divide_nonneg_nonneg R_nonneg simp: escape_rate_def)
show "(∫⇧+y. R x y / escape_rate x ∂count_space UNIV) = 1" for x
using escape_rate_pos[of x]
by (auto simp add: divide_ennreal[symmetric] nn_integral_divide ennreal_escape_rate[symmetric] intro!: ennreal_divide_self)
qed
lemma set_pmf_J: "set_pmf (J x) = I x"
using escape_rate_pos[of x] by (auto simp: set_pmf_iff J.rep_eq less_le)
interpretation exp_esc: pair_prob_space "distr (exponential (escape_rate x)) borel ((+) t)" "J x" for x
proof -
interpret prob_space "distr (exponential (escape_rate x)) borel ((+) t)"
by (intro prob_space.prob_space_distr prob_space_exponential_escape_rate) simp
show "pair_prob_space (distr (exponential (escape_rate x)) borel ((+) t)) (measure_pmf (J x))"
by standard
qed
subsection ‹Continuous-time Kernel›
definition K :: "(real × 'a) ⇒ (real × 'a) measure" where
"K = (λ(t, x). (distr (exponential (escape_rate x)) borel ((+) t)) ⨂⇩M J x)"
interpretation K: discrete_Markov_process "borel ⨂⇩M count_space UNIV" K
proof
show "K ∈ borel ⨂⇩M count_space UNIV →⇩M prob_algebra (borel ⨂⇩M count_space UNIV)"
unfolding K_def
apply measurable
apply (rule measurable_snd[THEN measurable_compose])
apply (auto simp: space_prob_algebra prob_space_measure_pmf)
done
qed
interpretation DTMC: MC_syntax J .
lemma in_space_S[simp]: "x ∈ space S"
by (simp add: space_pair_measure)
lemma in_space_T[simp]: "x ∈ space T"
by (simp add: space_pair_measure space_stream_space)
lemma in_space_lim_stream: "ω ∈ space (K.lim_stream x)"
unfolding K.space_lim_stream space_stream_space[symmetric] by simp
lemma prob_space_K_lim: "prob_space (K.lim_stream x)"
using K.lim_stream[THEN measurable_space] by (simp add: space_prob_algebra)
definition select_first :: "'a ⇒ ('a ⇒ real) ⇒ 'a ⇒ bool"
where "select_first x p y = (y ∈ I x ∧ (∀y'∈I x - {y}. p y < p y'))"
lemma select_firstD1: "select_first x p y ⟹ y ∈ I x"
by (simp add: select_first_def)
lemma select_first_unique:
assumes y: "select_first x p y1" " select_first x p y2" shows "y1 = y2"
proof -
have "y1 ≠ y2 ⟹ p y1 < p y2" "y1 ≠ y2 ⟹ p y2 < p y1"
using y by (auto simp: select_first_def)
then show "y1 = y2"
by (rule_tac ccontr) auto
qed
lemma The_select_first[simp]: "select_first x p y ⟹ The (select_first x p) = y"
by (intro the_equality select_first_unique)
lemma select_first_INF:
"select_first x p y ⟹ (INF x∈I x. p x) = p y"
by (intro antisym cINF_greatest cINF_lower bdd_belowI2[where m="p y"])
(auto simp: select_first_def le_less)
lemma measurable_select_first[measurable]:
"(λp. select_first x p y) ∈ (Π⇩M y∈I x. borel) →⇩M count_space UNIV"
using I_countable unfolding select_first_def by (intro measurable_pred_countable pred_intros_conj1') measurable
lemma measurable_THE_select_first[measurable]:
"(λp. The (select_first x p)) ∈ (Π⇩M y∈I x. borel) →⇩M count_space UNIV"
by (rule measurable_THE) (auto intro: select_first_unique I_countable dest: select_firstD1)
lemma sets_S_eq: "sets S = sigma_sets UNIV { {t ..} × A | t A. A ⊆ - I x ∨ (∃s∈I x. A = {s}) }"
proof (subst sets_pair_eq)
let ?CI = "λa::real. {a ..}" let ?Ea = "range ?CI"
show "?Ea ⊆ Pow (space borel)" "sets borel = sigma_sets (space borel) ?Ea"
unfolding borel_Ici by auto
show "?CI`Rats ⊆ ?Ea" "(⋃i∈Rats. ?CI i) = space borel"
using Rats_dense_in_real[of "x - 1" "x" for x] by (auto intro: less_imp_le)
let ?Eb = "Pow (- I x) ∪ (λs. {s}) ` I x"
have "b ∈ sigma_sets UNIV (Pow (- I x) ∪ (λs. {s}) ` I x)" for b
proof -
have "b = (b - I x) ∪ (⋃x∈b ∩ I x. {x})"
by auto
also have "… ∈ sigma UNIV (Pow (- I x) ∪ (λs. {s}) ` I x)"
using I_countable by (intro sets.Un sets.countable_UN') auto
finally show ?thesis
by simp
qed
then show "sets (count_space UNIV) = sigma_sets (space (count_space UNIV)) ?Eb"
by auto
show "countable ({- I x} ∪ (⋃s∈I x. {{s}}))"
using I_countable by auto
show "sets (sigma (space borel × space (count_space UNIV)) {a × b |a b. a ∈ ?Ea ∧ b ∈ ?Eb}) =
sigma_sets UNIV {{t ..} × A |t A. A ⊆ - I x ∨ (∃s∈I x. A = {s})}"
apply simp
apply (intro arg_cong[where f="sigma_sets _"])
apply auto
done
qed (auto intro: countable_rat)
subsection ‹Kernel equals Parallel Choice›
abbreviation PAR :: "'a ⇒ ('a ⇒ real) measure"
where
"PAR x ≡ (Π⇩M y∈I x. exponential (R x y))"
lemma PAR_least:
assumes y: "y ∈ I x"
shows "PAR x {p∈space (PAR x). t ≤ p y ∧ select_first x p y} =
emeasure (exponential (escape_rate x)) {t ..} * ennreal (pmf (J x) y)"
proof -
let ?E = "λy. exponential (R x y)" let ?P' = "Π⇩M y∈I x - {y}. ?E y"
interpret P': prob_space ?P'
by (intro prob_space_PiM prob_space_exponential) simp
have *: "PAR x = (Π⇩M y∈insert y (I x - {y}). ?E y)"
using y by (intro PiM_cong) auto
have "0 < R x y"
using y by simp
have **: "(λ(x, X). X(y := x)) ∈ exponential (R x y) ⨂⇩M Pi⇩M (I x - {y}) (λi. exponential (R x i)) →⇩M PAR x"
using y
apply (subst measurable_cong_sets[OF sets_pair_measure_cong[OF sets_exponential sets_PiM_cong[OF refl sets_exponential]] sets_PiM_cong[OF refl sets_exponential]])
apply measurable
apply (rule measurable_fun_upd[where J="I x - {y}"])
apply auto
done
have "PAR x {p∈space (PAR x). t ≤ p y ∧ (∀y'∈I x-{y}. p y < p y')} =
(∫⇧+ty. indicator {t..} ty * ?P' {p∈space ?P'. ∀y'∈I x-{y}. ty < p y'} ∂?E y)"
unfolding * using ‹y ∈ I x›
apply (subst distr_pair_PiM_eq_PiM[symmetric])
apply (auto intro!: prob_space_exponential simp: emeasure_distr insert_absorb)
apply (subst emeasure_distr[OF **])
subgoal
using I_countable by (auto simp: pred_def[symmetric])
apply (subst P'.emeasure_pair_measure_alt)
subgoal
using I_countable[of x]
apply (intro measurable_sets[OF **])
apply (auto simp: pred_def[symmetric])
done
apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator if_split_asm
simp: space_exponential space_PiM space_pair_measure PiE_iff extensional_def)
done
also have "… = (∫⇧+ty. indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y))) ∂?E y)"
apply (intro nn_integral_cong_AE)
using AE_exponential[OF ‹0 < R x y›]
proof eventually_elim
fix ty :: real assume "0 < ty"
have "escape_rate x =
(∫⇧+y'. R x y' * indicator {y} y' ∂count_space UNIV) + (∫⇧+y'. R x y' * indicator (I x - {y}) y' ∂count_space UNIV)"
unfolding ennreal_escape_rate by (subst nn_integral_add[symmetric]) (auto simp: less_le split: split_indicator intro!: nn_integral_cong)
also have "… = R x y + (∫⇧+y'. R x y' ∂count_space (I x - {y}))"
by (auto simp add: nn_integral_count_space_indicator less_le simp del: nn_integral_indicator_singleton
intro!: arg_cong2[where f="(+)"] nn_integral_cong split: split_indicator)
finally have "(∫⇧+y'. R x y' ∂count_space (I x - {y})) = escape_rate x - R x y ∧ R x y ≤ escape_rate x"
using escape_rate_pos[THEN less_imp_le]
by (cases "(∫⇧+y'. R x y' ∂count_space (I x - {y}))")
(auto simp: add_top ennreal_plus[symmetric] simp del: ennreal_plus)
then have "integrable (count_space (I x - {y})) (R x)" "(LINT y'|count_space (I x - {y}). R x y') = escape_rate x - R x y"
by (auto simp: nn_integral_eq_integrable)
then have "?P' (prod_emb (I x-{y}) ?E (I x-{y}) (Π⇩E j∈(I x-{y}). {ty<..})) = exp (- ty * (escape_rate x - R x y))"
using I_countable ‹0 < ty› by (subst emeasure_PiM_exponential_Ioi_countable) auto
also have "prod_emb (I x-{y}) ?E (I x-{y}) (Π⇩E j∈(I x-{y}). {ty<..}) = {p∈space ?P'. ∀y'∈I x-{y}. ty < p y'}"
by (simp add: set_eq_iff prod_emb_def space_PiM space_exponential ac_simps Pi_iff)
finally show "indicator {t..} ty * ?P' {p∈space ?P'. ∀y'∈I x-{y}. ty < p y'} =
indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y)))"
by simp
qed
also have "… = (∫⇧+ty. ennreal (R x y) * (ennreal (exp (- ty * escape_rate x)) * indicator {max 0 t..} ty) ∂lborel)"
by (auto simp add: exponential_def exponential_density_def nn_integral_density ennreal_mult[symmetric] exp_add[symmetric] field_simps
intro!: nn_integral_cong split: split_indicator)
also have "… = (R x y / escape_rate x) * emeasure (exponential (escape_rate x)) {max 0 t..}"
using escape_rate_pos[of x]
by (auto simp: exponential_def exponential_density_def emeasure_density nn_integral_cmult[symmetric] ennreal_mult[symmetric]
split: split_indicator intro!: nn_integral_cong )
also have "… = pmf (J x) y * emeasure (exponential (escape_rate x)) {t..}"
using AE_exponential[OF escape_rate_pos[of x]]
by (intro arg_cong2[where f="(*)"] emeasure_eq_AE) (auto simp: J.rep_eq )
finally show ?thesis
using assms by (simp add: mult_ac select_first_def)
qed
lemma AE_PAR_least: "AE p in PAR x. ∃y∈I x. select_first x p y"
proof -
have D: "disjoint_family_on (λy. {p ∈ space (PAR x). select_first x p y}) (I x)"
by (auto simp: disjoint_family_on_def dest: select_first_unique)
have "PAR x {p∈space (PAR x). ∃y∈I x. select_first x p y} =
PAR x (⋃y∈I x. {p∈space (PAR x). select_first x p y})"
by (auto intro!: arg_cong2[where f=emeasure])
also have "… = (∫⇧+y. PAR x {p∈space (PAR x). select_first x p y} ∂count_space (I x))"
using I_countable by (intro emeasure_UN_countable D) auto
also have "… = (∫⇧+y. PAR x {p∈space (PAR x). 0 ≤ p y ∧ select_first x p y} ∂count_space (I x))"
proof (intro nn_integral_cong emeasure_eq_AE, goal_cases)
case (1 y) with AE_PiM_component[of "I x" "λy. exponential (R x y)" y "(<) 0"] AE_exponential[of "R x y"] show ?case
by (auto simp: prob_space_exponential)
qed (insert I_countable, auto)
also have "… = (∫⇧+y. emeasure (exponential (escape_rate x)) {0 ..} * ennreal (pmf (J x) y) ∂count_space (I x))"
by (auto simp add: PAR_least intro!: nn_integral_cong)
also have "… = (∫⇧+y. emeasure (exponential (escape_rate x)) {0 ..} ∂J x)"
by (auto simp: nn_integral_measure_pmf nn_integral_count_space_indicator ac_simps pmf_eq_0_set_pmf set_pmf_J
simp del: nn_integral_const intro!: nn_integral_cong split: split_indicator)
also have "… = 1"
using AE_exponential[of "escape_rate x"]
by (auto intro!: prob_space.emeasure_eq_1_AE prob_space_exponential simp: escape_rate_pos less_imp_le)
finally show ?thesis
using I_countable
by (subst prob_space.AE_iff_emeasure_eq_1 prob_space_PiM prob_space_exponential)
(auto intro!: prob_space_PiM prob_space_exponential simp del: Set.bex_simps(6))
qed
lemma K_alt: "K (t, x) = distr (Π⇩M y∈I x. exponential (R x y)) S (λp. (t + (INF y∈I x. p y), The (select_first x p)))" (is "_ = ?R")
proof (rule measure_eqI_generator_eq_countable)
let ?E = "{ {t ..} × A | (t::real) A. A ⊆ - I x ∨ (∃s∈I x. A = {s}) }"
show "Int_stable ?E"
apply (auto simp: Int_stable_def)
subgoal for t1 A1 t2 A2
by (intro exI[of _ "max t1 t2"] exI[of _ "A1 ∩ A2"]) auto
subgoal for t1 t2 y1 y2
by (intro exI[of _ "max t1 t2"] exI[of _ "{y1} ∩ {y2}"]) auto
done
show "sets (K (t, x)) = sigma_sets UNIV ?E"
unfolding K.sets_K[OF in_space_S] by (subst sets_S_eq) rule
show "sets ?R = sigma_sets UNIV ?E"
using sets_S_eq by simp
show "countable ((λ(t, A). {t ..} × A) ` (ℚ × ({- I x} ∪ (λs. {s}) ` I x)))"
by (intro countable_image countable_SIGMA countable_rat countable_Un I_countable) auto
have *: "(+) t -` {t'..} ∩ space (exponential (escape_rate x)) = {t' - t..}" for t'
by (auto simp: space_exponential)
{ fix X assume "X ∈ ?E"
then consider
t' s where "s ∈ I x" "X = {t' ..} × {s}"
| t' A where "A ⊆ - I x" "X = {t' ..} × A"
by auto
then show "K (t, x) X = ?R X"
proof cases
case 1
have "AE p in PAR x. (t' - t ≤ p s ∧ select_first x p s) =
(t' ≤ t + (⨅x∈I x. p x) ∧ The (select_first x p) = s)"
using AE_PAR_least by eventually_elim (auto dest: select_first_unique simp: select_first_INF)
with 1 I_countable show ?thesis
by (auto simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr emeasure_pmf_single *
PAR_least[symmetric] intro!: emeasure_eq_AE)
next
case 2
moreover
then have "emeasure (measure_pmf (J x)) A = 0"
by (subst AE_iff_measurable[symmetric, where P="λx. x ∉ A"])
(auto simp: AE_measure_pmf_iff set_pmf_J subset_eq)
moreover
have "PAR x ((λp. (t + ⨅(p ` (I x)), The (select_first x p))) -` ({t'..} × A) ∩ space (PAR x)) = 0"
using ‹A ⊆ - I x› AE_PAR_least[of x] I_countable
by (subst AE_iff_measurable[symmetric, where P="λp. (t + ⨅(p ` (I x)), The (select_first x p)) ∉ {t'..} × A"])
(auto simp del: all_simps(5) simp add: imp_ex imp_conjL subset_eq)
ultimately show ?thesis
using I_countable
by (simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr *)
qed }
interpret prob_space "K ts" for ts
by (rule K.prob_space_K) simp
show "emeasure (K (t, x)) a ≠ ∞" for a
using emeasure_finite by simp
qed (insert Rats_dense_in_real[of "x - 1" x for x], auto, blast intro: less_imp_le)
lemma AE_K: "AE y in K x. fst x < fst y ∧ snd y ∈ J (snd x)"
unfolding K_def split_beta
apply (subst exp_esc.AE_pair_iff[symmetric])
apply measurable
apply (simp_all add: AE_distr_iff AE_measure_pmf_iff exponential_def AE_density exponential_density_def cong del: AE_cong)
using AE_lborel_singleton[of 0]
apply eventually_elim
apply simp
done
lemma AE_lim_stream:
"AE ω in K.lim_stream x. ∀i. snd ((x ## ω) !! i) ∈ DTMC.acc``{snd x} ∧ snd (ω !! i) ∈ J (snd ((x ## ω) !! i)) ∧ fst ((x ## ω) !! i) < fst (ω !! i)"
(is "AE ω in K.lim_stream x. ∀i. ?P ω i")
unfolding AE_all_countable
proof
let ?F = "λi x ω. fst ((x ## ω) !! i)" and ?S = "λi x ω. snd ((x ## ω) !! i)"
fix i show "AE ω in K.lim_stream x. ?P ω i"
proof (induction i arbitrary: x)
case 0 with AE_K[of x] show ?case
by (subst K.AE_lim_stream) (auto simp add: space_pair_measure cong del: AE_cong)
next
case (Suc i)
show ?case
proof (subst K.AE_lim_stream, goal_cases)
case 2 show ?case
using DTMC.countable_reachable
by (intro measurable_compose_countable_restrict[where f="?S (Suc i) x"])
(simp_all del: Image_singleton_iff)
next
case 3 show ?case
apply (simp del: AE_conj_iff cong del: AE_cong)
using AE_K[of x]
apply eventually_elim
subgoal premises K_prems for y
using Suc
by eventually_elim (insert K_prems, auto intro: converse_rtrancl_into_rtrancl)
done
qed (simp add: space_pair_measure)
qed
qed
lemma measurable_merge_at[measurable]: "(λ(ω, ω'). merge_at ω j ω') ∈ (T ⨂⇩M T) →⇩M T"
proof (rule measurable_stream_space2)
define F where "F x n = (case x of (ω::(real × 'a) stream, ω') ⇒ merge_at ω j ω') !! n" for x n
fix n
have "(λx. F x n) ∈ stream_space S ⨂⇩M stream_space S →⇩M S"
proof (induction n)
case 0 then show ?case
by (simp add: F_def split_beta' stream.case_eq_if)
next
case (Suc n)
from Suc[measurable]
have eq: "F x (Suc n) = (case fst x of (t, s) ## ω ⇒ if t ≤ j then F (ω, snd x) n else snd x !! Suc n)" for x
by (auto simp: F_def split: prod.split stream.split)
show ?case
unfolding eq stream.case_eq_if by measurable
qed
then show "(λx. (case x of (ω, ω') ⇒ merge_at ω j ω') !! n) ∈ stream_space S ⨂⇩M stream_space S →⇩M S"
unfolding F_def by auto
qed
lemma measurable_trace_at[measurable]: "(λ(s, ω). trace_at s ω j) ∈ (count_space UNIV ⨂⇩M T) →⇩M count_space UNIV"
unfolding trace_at_eq by measurable
lemma measurable_trace_at': "(λ((s, j), ω). trace_at s ω j) ∈ ((count_space UNIV ⨂⇩M borel) ⨂⇩M T) →⇩M count_space UNIV"
unfolding trace_at_eq split_beta' by measurable
lemma K_time_split:
assumes "t ≤ j" and [measurable]: "f ∈ S →⇩M borel"
shows "(∫⇧+x. f x * indicator {j <..} (fst x) ∂K (t, s)) = (∫⇧+x. f x ∂K (j, s)) * exponential (escape_rate s) {j - t <..}"
proof -
have "(∫⇧+ y. ∫⇧+ x. f (t + x, y) * indicator {j<..} (t + x) ∂exponential (escape_rate s) ∂J s) =
(∫⇧+ y. ∫⇧+ x. f (t + x, y) * indicator {j - t<..} x ∂exponential (escape_rate s) ∂J s)"
by (intro nn_integral_cong) (auto split: split_indicator)
also have "… = (∫⇧+ y. ∫⇧+ x. f (t + x, y) ∂uniform_measure (exponential (escape_rate s)) {j-t <..} ∂J s) *
emeasure (exponential (escape_rate s)) {j - t <..}"
using ‹t ≤ j› escape_rate_pos
by (subst nn_integral_uniform_measure)
(auto simp: nn_integral_divide ennreal_divide_times emeasure_exponential_Ioi)
also have "… = (∫⇧+ y. ∫⇧+ x. f (j + x, y) ∂exponential (escape_rate s) ∂J s) *
emeasure (exponential (escape_rate s)) {j - t <..}"
using ‹t ≤ j› escape_rate_pos by (simp add: uniform_measure_exponential nn_integral_distr)
finally show ?thesis
by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr)
qed
lemma K_in_space[simp]: "K x ∈ space (prob_algebra S)"
by (rule measurable_space [OF K.K]) simp
lemma L_in_space[simp]: "K.lim_stream x ∈ space (prob_algebra T)"
by (rule measurable_space [OF K.lim_stream]) simp
subsection ‹Markov Chain Property›
lemma lim_time_split:
"t ≤ j ⟹ K.lim_stream (t, s) = do { ω ← K.lim_stream (t, s) ; ω' ← K.lim_stream (j, trace_at s ω j) ; return T (merge_at ω j ω')}"
(is "_ ⟹ _ = ?DO t s")
proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
case step let ?L = K.lim_stream
note measurable_compose[OF measurable_prob_algebraD measurable_emeasure_subprob_algebra, measurable (raw)]
define B' where "B' = (λ(t', s). if t' ≤ j then ?DO t' s else ?L (t', s))"
show ?case
proof (intro bexI conjI AE_I2)
show [measurable]: "B' ∈ S →⇩M prob_algebra T"
unfolding B'_def by measurable
show "(∃t s. y = (t, s) ∧ B' y = ?DO t s ∧ t ≤ j) ∨ ?L y = B' y" for y
by (cases y; cases "fst y ≤ j") (auto simp: B'_def)
let ?C = "λx. do { ω ← ?L x; ω' ← ?L (j, trace_at s (x##ω) j); return T (merge_at (x##ω) j ω') }"
have "?DO t s = do { x ← K (t, s); ?C x }"
apply (subst K.lim_stream_eq[OF in_space_S])
apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
apply (subst measurable_cong_sets[OF K.sets_K[OF in_space_S] refl])
apply measurable
apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
apply measurable
apply (subst bind_cong[OF refl bind_cong[OF refl bind_return[OF measurable_prob_algebraD]]])
apply measurable
done
also have "… = K (t, s) ⤜ (λy. B' y ⤜ (λω. return T (y ## ω)))" (is "?DO' = ?R")
proof (rule measure_eqI)
have "sets ?DO' = sets T"
by (intro sets_bind'[OF K_in_space]) measurable
moreover have "sets ?R = sets T"
by (intro sets_bind'[OF K_in_space]) measurable
ultimately show "sets ?DO' = sets ?R"
by simp
fix A assume "A ∈ sets ?DO'"
then have A[measurable]: "A ∈ T"
unfolding ‹sets ?DO' = sets T› .
have "?DO' A = (∫⇧+x. ?C x A ∂K (t, s))"
by (subst emeasure_bind_prob_algebra[OF K_in_space]) measurable
also have "… = (∫⇧+x. ?C x A * indicator {.. j} (fst x) ∂K (t, s)) +
(∫⇧+x. ?C x A * indicator {j <..} (fst x) ∂K (t, s))"
by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
also have "(∫⇧+x. ?C x A * indicator {.. j} (fst x) ∂K (t, s)) =
(∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A * indicator {.. j} (fst y) ∂K (t, s))"
proof (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
fix x :: "real × 'a" assume "indicator {..j} (fst x) ≠ (0::ennreal)"
then have "fst x ≤ j"
by (auto split: split_indicator_asm)
then show "?C x = (B' x ⤜ (λω. return T (x ## ω)))"
apply (cases x)
apply (simp add: B'_def)
apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
apply measurable
apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
apply measurable
apply (subst bind_return)
apply measurable
done
qed
also have "(∫⇧+x. ?C x A * indicator {j <..} (fst x) ∂K (t, s)) =
(∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A * indicator {j <..} (fst y) ∂K (t, s))"
proof -
have *: "(+) t -` {j<..} = {j - t <..}"
by auto
have "(∫⇧+x. ?C x A * indicator {j <..} (fst x) ∂K (t, s)) =
(∫⇧+x. ?L (j, s) A * indicator {j <..} (fst x) ∂K (t, s))"
by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
(auto simp: K.sets_lim_stream bind_return'' bind_const' prob_space_K_lim prob_space_imp_subprob_space split: split_indicator_asm)
also have "… = ?L (j, s) A * exponential (escape_rate s) {j - t <..}"
by (subst nn_integral_cmult) (simp_all add: K_def exp_esc.nn_integral_snd[symmetric] emeasure_distr space_exponential *)
also have "… = (∫⇧+x. emeasure (?L x ⤜ (λω. return T (x ## ω))) A ∂K (j, s)) * exponential (escape_rate s) {j - t <..}"
by (subst K.lim_stream_eq) (auto simp: emeasure_bind_prob_algebra[OF K_in_space _ A])
also have "… = (∫⇧+y. emeasure (?L y ⤜ (λω. return T (y ## ω))) A * indicator {j <..} (fst y) ∂K (t, s))"
using ‹t ≤ j› by (rule K_time_split[symmetric]) measurable
also have "… = (∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A * indicator {j <..} (fst y) ∂K (t, s))"
by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
(auto simp add: B'_def split: split_indicator_asm)
finally show ?thesis .
qed
also have "(∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A * indicator {.. j} (fst y) ∂K (t, s)) +
(∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A * indicator {j <..} (fst y) ∂K (t, s)) =
(∫⇧+y. emeasure (B' y ⤜ (λω. return T (y ## ω))) A ∂K (t, s))"
by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
also have "… = emeasure (K (t, s) ⤜ (λy. B' y ⤜ (λω. return T (y ## ω)))) A"
by (rule emeasure_bind_prob_algebra[symmetric, OF K_in_space _ A]) auto
finally show "?DO' A = emeasure (K (t, s) ⤜ (λy. B' y ⤜ (λω. return T (y ## ω)))) A" .
qed
finally show "?DO t s = K (t, s) ⤜ (λy. B' y ⤜ (λω. return T (y ## ω)))" .
qed
qed (simp add: space_pair_measure)
lemma K_eq: "K (t, s) = distr (exponential (escape_rate s) ⨂⇩M J s) S (λ(t', s). (t + t', s))"
proof -
have "distr (exponential (escape_rate s)) borel ((+) t) ⨂⇩M distr (J s) (J s) (λx. x) =
distr (exponential (escape_rate s) ⨂⇩M J s) (borel ⨂⇩M J s) (λ(x, y). (t + x, y))"
proof (intro pair_measure_distr)
interpret prob_space "distr (measure_pmf (J s)) (measure_pmf (J s)) (λx. x)"
by (intro measure_pmf.prob_space_distr) simp
show "sigma_finite_measure (distr (measure_pmf (J s)) (measure_pmf (J s)) (λx. x))"
by unfold_locales
qed auto
also have "… = distr (exponential (escape_rate s) ⨂⇩M J s) S (λ(x, y). (t + x, y))"
by (intro distr_cong refl sets_pair_measure_cong) simp
finally show ?thesis
by (simp add: K_def)
qed
lemma K_shift: "K (t + t', s) = distr (K (t, s)) S (λ(t, s). (t + t', s))"
unfolding K_eq by (subst distr_distr) (auto simp: comp_def split_beta' ac_simps)
lemma K_not_empty: "space (K x) ≠ {}"
by (simp add: K_def space_pair_measure split: prod.split)
lemma lim_stream_not_empty: "space (K.lim_stream x) ≠ {}"
by (simp add: K.space_lim_stream space_pair_measure split: prod.split)
lemma lim_shift:
"K.lim_stream (t + t', s) = distr (K.lim_stream (t, s)) T (smap (λ(t, s). (t + t', s)))"
(is "_ = ?D t s")
proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
case step then show ?case
proof (intro bexI[of _ "λ(t, s). ?D (t - t') s"] conjI)
show "?D t s = K (t + t', s) ⤜ (λy. (case y of (t, s) ⇒ ?D (t - t') s) ⤜ (λω. return T (y ## ω)))"
apply (subst K.lim_stream_eq[OF in_space_S])
apply (subst K_shift)
apply (subst distr_bind[OF measurable_prob_algebraD K_not_empty])
apply (measurable; fail)
apply (measurable; fail)
apply (subst bind_distr[OF _ measurable_prob_algebraD K_not_empty])
apply (measurable; fail)
apply (measurable; fail)
apply (intro bind_cong refl)
apply (subst distr_bind[OF measurable_prob_algebraD lim_stream_not_empty])
apply (measurable; fail)
apply (measurable; fail)
apply (simp add: distr_return split_beta)
apply (subst bind_distr[OF _ measurable_prob_algebraD lim_stream_not_empty])
apply (measurable; fail)
apply (measurable; fail)
apply (simp add: split_beta')
done
qed (auto cong: conj_cong intro!: exI[of _ "_ - t'"])
qed simp
lemma lim_0: "K.lim_stream (t, s) = distr (K.lim_stream (0, s)) T (smap (λ(t', s). (t' + t, s)))"
using lim_shift[of 0 t s] by simp
subsection ‹Explosion time›
definition explosion :: "(real × 'a) stream ⇒ ereal"
where "explosion ω = (SUP i. ereal (fst (ω !! i)))"
lemma ball_less_Suc_eq: "(∀i<Suc n. P i) ⟷ (P 0 ∧ (∀i<n. P (Suc i)))"
using less_Suc_eq_0_disj by auto
lemma lim_stream_timediff_eq_exponential_1:
"distr (K.lim_stream ts) (PiM UNIV (λ_. borel))
(λω i. escape_rate (snd ((ts##ω) !! i)) * (fst (ω !! i) - fst ((ts##ω) !! i))) =
PiM UNIV (λ_. exponential 1)"
(is "?D = ?P")
proof (rule measure_eqI_PiM_sequence)
show "sets ?D = sets (PiM UNIV (λ_. borel))" "sets ?P = sets (PiM UNIV (λ_. borel))"
by (auto intro!: sets_PiM_cong simp: sets_exponential)
have [measurable]: "ts ∈ space S"
by auto
{ interpret prob_space ?D
by (intro prob_space.prob_space_distr K.prob_space_lim_stream measurable_abs_UNIV) auto
show "finite_measure ?D"
by unfold_locales }
interpret E: prob_space "exponential 1"
by (rule prob_space_exponential) simp
interpret P: product_prob_space "λ_. exponential 1" UNIV
by unfold_locales
let "distr _ _ (?f ts)" = ?D
fix A :: "nat ⇒ real set" and n :: nat assume A[measurable]: "⋀i. A i ∈ sets borel"
define n' where "n' = Suc n"
have "emeasure ?D (prod_emb UNIV (λ_. borel) {..n} (Pi⇩E {..n} A)) =
emeasure (K.lim_stream ts) {ω∈space (stream_space S). ∀i<n'. ?f ts ω i ∈ A i}"
apply (subst emeasure_distr)
apply (auto intro!: measurable_abs_UNIV arg_cong[where f="emeasure _"])
apply (auto simp: prod_emb_def K.space_lim_stream space_pair_measure n'_def)
done
also have "… = (∏i<n'. emeasure (exponential 1) (A i))"
using A
proof (induction n' arbitrary: A ts)
case 0 then show ?case
using prob_space.emeasure_space_1[OF prob_space_K_lim]
by (simp add: K.space_lim_stream space_pair_measure)
next
case (Suc n A ts)
from Suc.prems[measurable]
have [measurable]: "ts ∈ space S"
by auto
have "emeasure (K.lim_stream ts) {ω ∈ space (stream_space S). ∀i<Suc n. ?f ts ω i ∈ A i} =
(∫⇧+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) *
emeasure (K.lim_stream ts') {ω ∈ space (stream_space S). ∀i<n. ?f ts' ω i ∈ A (Suc i)} ∂K ts)"
apply (subst K.emeasure_lim_stream)
apply simp
apply measurable
apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator
simp: ball_less_Suc_eq)
done
also have "… = (∫⇧+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) ∂K ts) *
(∏i<n. emeasure (exponential 1) (A (Suc i)))"
by (subst Suc.IH) (simp_all add: nn_integral_multc)
also have "(∫⇧+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) ∂K ts) =
(∫⇧+t. indicator (A 0) (escape_rate (snd ts) * t) ∂exponential (escape_rate (snd ts)))"
by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr split: prod.split)
also have "… = emeasure (exponential 1) (A 0)"
using escape_rate_pos[of "snd ts"]
by (subst exponential_eq_stretch) (simp_all add: nn_integral_distr)
also have "emeasure (exponential 1) (A 0) * (∏i<n. emeasure (exponential 1) (A (Suc i))) =
(∏i<Suc n. emeasure (exponential 1) (A i))"
by (rule prod.lessThan_Suc_shift[symmetric])
finally show ?case .
qed
also have "… = emeasure ?P (prod_emb UNIV (λ_. borel) {..<n'} (Pi⇩E {..<n'} A))"
using P.emeasure_PiM_emb[of "{..<n'}" A] by (simp add: prod_emb_def space_exponential)
finally show "emeasure ?D (prod_emb UNIV (λ_. borel) {..n} (Pi⇩E {..n} A)) =
emeasure ?P (prod_emb UNIV (λ_. borel) {..n} (Pi⇩E {..n} A))"
by (simp add: n'_def lessThan_Suc_atMost)
qed
lemma AE_explosion_infty:
assumes bdd: "bdd_above (range escape_rate)"
shows "AE ω in K.lim_stream x. explosion ω = ∞"
proof -
have "escape_rate undefined ≤ (SUP x. escape_rate x)"
using bdd by (intro cSUP_upper) auto
then have SUP_escape_pos: "0 < (SUP x. escape_rate x)"
using escape_rate_pos[of undefined] by simp
then have SUP_escape_nonneg: "0 ≤ (SUP x. escape_rate x)"
by (rule less_imp_le)
have [measurable]: "x ∈ space S" by auto
have "(∑i. 1::ennreal) = top"
by (rule sums_unique[symmetric]) (auto simp: sums_def of_nat_tendsto_top_ennreal)
then have "AE ω in (PiM UNIV (λ_. exponential 1)). (∑i. ereal (ω i)) = ∞"
by (intro AE_PiM_exponential_suminf_infty) auto
then have "AE ω in K.lim_stream x.
(∑i. ereal (escape_rate (snd ((x##ω) !! i)) * (fst (ω !! i) - fst ((x##ω) !! i)))) = ∞"
apply (subst (asm) lim_stream_timediff_eq_exponential_1[symmetric, of x])
apply (subst (asm) AE_distr_iff)
apply (auto intro!: measurable_abs_UNIV)
done
then show ?thesis
using AE_lim_stream
proof eventually_elim
case (elim ω)
then have le: "fst ((x##ω) !! n) ≤ fst ((x ## ω) !! m)" if "n ≤ m" for n m
by (intro lift_Suc_mono_le[OF _ ‹n ≤ m›, of "λi. fst ((x ## ω) !! i)"]) (auto intro: less_imp_le)
have [simp]: "fst x ≤ fst ((x##ω) !! i)" "fst ((x##ω) !! i) ≤ fst (ω !! i)" for i
using le[of "i" "Suc i"] le[of 0 i] by auto
have "(∑i. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i)))) =
(SUP n. ∑i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i))))"
by (intro suminf_ereal_eq_SUP) (auto intro!: mult_nonneg_nonneg)
also have "… ≤ (SUP n. (SUP x. escape_rate x) * (ereal (fst ((x ## ω) !! n)) - ereal (fst x)))"
proof (intro SUP_least SUP_upper2)
fix n
have "(∑i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i)))) ≤
(∑i<n. ereal ((SUP i. escape_rate i) * (fst (ω !! i) - fst ((x ## ω) !! i))))"
using elim bdd by (intro sum_mono) (auto intro!: cSUP_upper)
also have "… = (SUP i. escape_rate i) * (∑i<n. fst ((x ## ω) !! Suc i) - fst ((x ## ω) !! i))"
using elim bdd by (subst sum_ereal) (auto simp: sum_distrib_left)
also have "… = (SUP i. escape_rate i) * (fst ((x ## ω) !! n) - fst x)"
by (subst sum_lessThan_telescope) simp
finally show "(∑i<n. ereal (escape_rate (snd ((x ## ω) !! i)) * (fst (ω !! i) - fst ((x ## ω) !! i))))
≤ (SUP x. escape_rate x) * (ereal (fst ((x ## ω) !! n)) - ereal (fst x))"
by simp
qed simp
also have "… = (SUP x. escape_rate x) * ((SUP n. ereal (fst ((x ## ω) !! n))) - ereal (fst x))"
using elim SUP_escape_nonneg by (subst SUP_ereal_mult_left) (auto simp: SUP_ereal_minus_left[symmetric])
also have "(SUP n. ereal (fst ((x ## ω) !! n))) = explosion ω"
unfolding explosion_def
apply (intro SUP_eq)
subgoal for i by (intro bexI[of _ i]) auto
subgoal for i by (intro bexI[of _ "Suc i"]) auto
done
finally show "explosion ω = ∞"
using elim SUP_escape_pos by (cases "explosion ω") (auto split: if_splits)
qed
qed
subsection ‹Transition probability $p_t$›
context
begin
declare [[inductive_internals = true]]
inductive trace_in :: "'a set ⇒ real ⇒ 'a ⇒ (real × 'a) stream ⇒ bool" for S t
where
"t < t' ⟹ s ∈ S ⟹ trace_in S t s ((t', s')##ω)"
| "t ≥ t' ⟹ trace_in S t s' ω ⟹ trace_in S t s ((t', s')##ω)"
end
lemma trace_in_simps[simp]:
"trace_in ss t s (x##ω) = (if t < fst x then s ∈ ss else trace_in ss t (snd x) ω)"
by (cases x) (subst trace_in.simps; auto)
lemma trace_in_eq_lfp:
"trace_in ss t = lfp (λF s. λ(t', s')##ω ⇒ if t < t' then s ∈ ss else F s' ω)"
unfolding trace_in_def by (intro arg_cong[where f=lfp] ext) (auto split: stream.splits)
lemma trace_in_shiftD: "trace_in ss t s ω ⟹ trace_in ss (t + t') s (smap (λ(t, s'). (t + t', s')) ω)"
by (induction rule: trace_in.induct) auto
lemma trace_in_shift[simp]: "trace_in ss t s (smap (λ(t, s'). (t + t', s')) ω) ⟷ trace_in ss (t - t') s ω"
using trace_in_shiftD[of ss t s "smap (λ(t, s'). (t + t', s')) ω" "- t'"]
trace_in_shiftD[of ss "t - t'" s ω t']
by (auto simp add: stream.map_comp prod.case_eq_if)
lemma measurable_trace_in':
"Measurable.pred (borel ⨂⇩M count_space UNIV ⨂⇩M T) (λ(t, s, ω). trace_in ss t s ω)"
(is "?M (λ(t, s, ω). trace_in ss t s ω)")
proof -
let ?F = "λF. λ(t, s, (t', s')##ω) ⇒ if t < t' then s ∈ ss else F (t, s', ω)"
have [measurable]: "Measurable.pred (count_space UNIV) (λx. x ∈ ss)"
by simp
have "trace_in ss = (λt s ω. lfp ?F (t, s, ω))"
unfolding trace_in_def
apply (subst lfp_arg)
apply (subst lfp_rolling[where g="λF t s ω. F (t, s, ω)"])
subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
subgoal
by (intro arg_cong[where f=lfp])
(auto simp: mono_def le_fun_def split_beta' not_less fun_eq_iff split: stream.splits intro!: arg_cong[where f=lfp])
done
then have eq: "(λ(t, s, ω). trace_in ss t s ω) = lfp ?F"
by simp
have "sup_continuous ?F"
by (auto simp: sup_continuous_def fun_eq_iff split: stream.splits)
then show ?thesis
unfolding eq
proof (rule measurable_lfp)
fix F assume "?M F" then show "?M (?F F)"
by measurable
qed
qed
lemma measurable_trace_in[measurable (raw)]:
assumes [measurable]: "f ∈ M →⇩M borel" "g ∈ M →⇩M count_space UNIV" "h ∈ M →⇩M T"
shows "Measurable.pred M (λx. trace_in ss (f x) (g x) (h x))"
using measurable_compose[of "λx. (f x, g x, h x)" M, OF _ measurable_trace_in'[of ss]] by simp
definition p :: "'a ⇒ 'a ⇒ real ⇒ real"
where "p s s' t = 𝒫(ω in K.lim_stream (0, s). trace_in {s'} t s ω)"
lemma p[measurable]: "(λ(s, t). p s s' t) ∈ (count_space UNIV ⨂⇩M borel) →⇩M borel"
proof -
have *: "(SIGMA x:space (count_space UNIV ⨂⇩M borel). {ω ∈ streams (space S). trace_in {s'} (snd x) (fst x) ω}) =
{x∈space ((count_space UNIV ⨂⇩M borel) ⨂⇩M T). trace_in {s'} (snd (fst x)) (fst (fst x)) (snd x)}"
by (auto simp: space_pair_measure)
note measurable_trace_at'[measurable]
show ?thesis
unfolding p_def[abs_def] split_beta'
by (rule measure_measurable_prob_algebra2[where N=T])
(auto simp: K.space_lim_stream * pred_def[symmetric]
intro!: pred_count_space_const1 measurable_trace_at'[unfolded split_beta'])
qed
lemma p_nonpos: assumes "t ≤ 0" shows "p s s' t = of_bool (s = s')"
proof -
have "AE ω in K.lim_stream (0, s). trace_in {s'} t s ω = (s = s')"
proof (subst K.AE_lim_stream)
show "AE y in K (0, s). AE ω in K.lim_stream y. trace_in {s'} t s (y ## ω) = (s = s')"
using AE_K
proof eventually_elim
fix y :: "real × 'a" assume "fst (0, s) < fst y ∧ snd y ∈ set_pmf (J (snd (0, s)))"
with ‹t≤0› show "AE ω in K.lim_stream y. trace_in {s'} t s (y ## ω) = (s = s')"
by (cases y) auto
qed
qed auto
then have "p s s' t = 𝒫(ω in K.lim_stream (0, s). s = s')"
unfolding p_def by (intro prob_space.prob_eq_AE K.prob_space_lim_stream) auto
then show ?thesis
using prob_space.prob_space[OF K.prob_space_lim_stream] by simp
qed
lemma p_0: "p s s' 0 = of_bool (s = s')"
using p_nonpos[of 0] by simp
lemma in_sets_T[measurable (raw)]: "Measurable.pred T P ⟹ {ω. P ω} ∈ sets T"
unfolding pred_def by simp
lemma distr_id': "sets M = sets N ⟹ distr M N (λx. x) = M"
by (subst distr_cong[of M M N M _ "λx. x"] ) simp_all
lemma p_nonneg[simp]: "0 ≤ p s s' t"
by (simp add: p_def)
lemma p_le_1[simp]: "p s s' t ≤ 1"
unfolding p_def by (intro prob_space.prob_le_1 K.prob_space_lim_stream) simp
lemma p_eq:
assumes "0 ≤ t"
shows "p s s'' t = (of_bool (s = s'') + (LINT u:{0..t}|lborel. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
proof -
have *: "(+) 0 = (λx::real. x)"
by auto
interpret L: prob_space "K.lim_stream x" for x
by (rule K.prob_space_lim_stream) simp
interpret E: prob_space "exponential (escape_rate s)" for s
by (intro escape_rate_pos prob_space_exponential)
have "p s s'' t = emeasure (K.lim_stream (0, s)) {ω∈space T. trace_in {s''} t s ω}"
by (simp add: p_def L.emeasure_eq_measure K.space_lim_stream space_stream_space del: in_space_T)
also have "… = (∫⇧+y. emeasure (K.lim_stream y) {ω∈space T. trace_in {s''} t s (y##ω) } ∂K (0, s))"
apply (subst K.lim_stream_eq[OF in_space_S])
apply (subst emeasure_bind_prob_algebra[OF K_in_space])
apply (measurable; fail)
apply (measurable; fail)
apply (subst bind_return_distr'[OF lim_stream_not_empty])
apply (measurable; fail)
apply (simp add: emeasure_distr)
done
also have "… = (∫⇧+y. indicator {t <..} (fst y) * of_bool (s = s'') + indicator {0<..t} (fst y) * p (snd y) s'' (t - fst y) ∂K (0, s))"
apply (intro nn_integral_cong_AE)
using AE_K
apply eventually_elim
subgoal for y
using L.emeasure_space_1
apply (cases y)
apply (auto split: split_indicator simp del: in_space_T)
subgoal for t' s2
unfolding p_def L.emeasure_eq_measure[symmetric] K.space_lim_stream space_stream_space[symmetric]
by (subst lim_0) (simp add: emeasure_distr)
subgoal
by (auto split: split_indicator cong: rev_conj_cong simp add: K.space_lim_stream space_stream_space simp del: in_space_T)
done
done
also have "… = (∫⇧+u. ∫⇧+s'. indicator {t <..} u * of_bool (s = s'') +
indicator {0<..t} u * p s' s'' (t - u) ∂J s ∂exponential (escape_rate s))"
unfolding K_def
by (simp add: K_def measure_pmf.nn_integral_fst[symmetric] * distr_id' sets_exponential)
also have "… = ennreal (exp (- t * escape_rate s) * of_bool (s = s'')) +
(∫⇧+u. indicator {0<..t} u * ∫⇧+s'. p s' s'' (t - u) ∂J s ∂exponential (escape_rate s))"
using ‹0≤t› by (simp add: nn_integral_add nn_integral_cmult ennreal_indicator ennreal_mult emeasure_exponential_Ioi escape_rate_pos)
also have "(∫⇧+u. indicator {0<..t} u * ∫⇧+s'. p s' s'' (t - u) ∂J s ∂exponential (escape_rate s)) =
(∫⇧+u. indicator {0<..t} u *⇩R (LINT s'|J s. p s' s'' (t - u)) ∂exponential (escape_rate s))"
by (simp add: measure_pmf.integrable_const_bound[of _ 1] nn_integral_eq_integral ennreal_mult ennreal_indicator)
also have "… = (LINT u:{0<..t}|exponential (escape_rate s). (LINT s'|J s. p s' s'' (t - u)))"
unfolding set_lebesgue_integral_def
by (intro nn_integral_eq_integral E.integrable_const_bound[of _ 1] AE_I2)
(auto intro!: mult_le_one measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
also have "… = (LINT u:{0<..t}|lborel. escape_rate s * exp (- escape_rate s * u) * (LINT s'|J s. p s' s'' (t - u)))"
unfolding exponential_def set_lebesgue_integral_def
by (subst integral_density)
(auto simp: ac_simps exponential_density_def fun_eq_iff split: split_indicator
simp del: integral_mult_right integral_mult_right_zero intro!: arg_cong2[where f="integral⇧L"])
also have "… = (LINT u:{0..t}|lborel. escape_rate s * exp (- escape_rate s * (t - u)) * (LINT s'|J s. p s' s'' u))"
using AE_lborel_singleton[of 0] AE_lborel_singleton[of t] unfolding set_lebesgue_integral_def
by (subst lborel_integral_real_affine[where t=t and c="-1"])
(auto intro!: integral_cong_AE split: split_indicator)
also have "… = exp (- t * escape_rate s) * escape_rate s * (LINT u:{0..t}|lborel. exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))"
by (simp add: field_simps exp_diff exp_minus)
finally show "p s s'' t = (of_bool (s = s'') + (LBINT u:{0..t}. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
unfolding set_lebesgue_integral_def
by (simp del: ennreal_plus add: ennreal_plus[symmetric] exp_minus field_simps)
qed
lemma continuous_on_p: "continuous_on A (p s s')"
proof -
interpret E: prob_space "exponential (escape_rate s'')" for s''
by (intro escape_rate_pos prob_space_exponential)
have "continuous_on {..0} (p s s')"
by (simp add: p_nonpos continuous_on_const cong: continuous_on_cong_simp)
moreover have "continuous_on {0..} (p s s')"
proof (subst continuous_on_cong[OF refl p_eq])
let ?I = "λt. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
show "continuous_on {0..} (λt. (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) / exp (t * escape_rate s))"
proof (intro continuous_intros continuous_on_LBINT[THEN continuous_on_subset])
fix t :: real assume t: "0 ≤ t"
then have "0 ≤ x ⟹ x ≤ t ⟹ exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x) ≤ exp (t * escape_rate s) * 1" for x
by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
with t show "set_integrable lborel {0..t} ?I"
using escape_rate_pos[of s] unfolding set_integrable_def
by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
(auto simp: field_simps)
qed auto
qed simp
ultimately have "continuous_on ({0..} ∪ {..0}) (p s s')"
by (intro continuous_on_closed_Un) auto
also have "{0..} ∪ {..0::real} = UNIV" by auto
finally show ?thesis
by (rule continuous_on_subset) simp
qed
lemma p_vector_derivative:
assumes "0 ≤ t"
shows "(p s s' has_vector_derivative (LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t)
(at t within {0..})"
(is "(_ has_vector_derivative ?A) _")
proof -
let ?I = "λt. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
let ?p = "λt. (of_bool (s = s') + integral {0..t} ?I) * exp (t *⇩R - escape_rate s)"
{ fix t :: real assume "0 ≤ t"
have "p s s' t = (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) * exp (- t * escape_rate s)"
using p_eq[OF ‹0 ≤ t›, of s s'] by (simp add: exp_minus field_simps)
also have "(LBINT u:{0..t}. ?I u) = integral {0..t} ?I"
proof (intro set_borel_integral_eq_integral)
have "0 ≤ x ⟹ x ≤ t ⟹ exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x) ≤ exp (t * escape_rate s) * 1" for x
by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
with ‹0≤t› show "set_integrable lborel {0..t} ?I"
using escape_rate_pos[of s] unfolding set_integrable_def
by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
(auto simp: field_simps)
qed
finally have "p s s' t = ?p t"
by simp }
note p_eq = this
have at_eq: "at t within {0..} = at t within {0 .. t + 1}"
by (intro at_within_nhd[where S="{..< t+1}"]) auto
have c_I: "continuous_on {0..t + 1} ?I"
by (intro continuous_intros continuous_on_LINT_pmf[where B=1] continuous_on_p) simp
show ?thesis
proof (subst has_vector_derivative_cong_ev)
show "∀⇩F u in nhds t. u ∈ {0..} ⟶ p s s' u = ?p u" "p s s' t = ?p t"
using ‹0≤t› by (simp_all add: p_eq)
have "(?p has_vector_derivative escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t)) (at t within {0..})"
unfolding at_eq
apply (intro refl derivative_eq_intros)
apply rule
apply (rule integral_has_vector_derivative[OF c_I])
apply (simp add: ‹0 ≤ t›)
apply rule
apply (rule exp_scaleR_has_vector_derivative_right)
apply (simp add: field_simps exp_minus p_eq ‹0≤t› split del: split_of_bool)
done
also have "escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t) =
(LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t"
using escape_rate_pos[of s]
by (simp add: measure_pmf_eq_density integral_density J.rep_eq field_simps)
finally show "(?p has_vector_derivative ?A) (at t within {0..})" .
qed
qed
coinductive wf_times :: "real ⇒ (real × 'a) stream ⇒ bool"
where
"t < t' ⟹ wf_times t' ω ⟹ wf_times t ((t', s') ## ω)"
lemma wf_times_simp[simp]: "wf_times t (x ## ω) ⟷ t < fst x ∧ wf_times (fst x) ω"
by (cases x) (subst wf_times.simps; simp)
lemma trace_in_merge_at:
assumes ω': "wf_times t' ω'"
shows "trace_in ss t x (merge_at ω t' ω') ⟷
(if t < t' then trace_in ss t x ω else ∃y. trace_in {y} t' x ω ∧ trace_in ss t y ω')"
(is "?merge ⟷ ?cases")
proof safe
assume ?merge from this ω' show ?cases
proof (induction ω≡"merge_at ω t' ω'" arbitrary: ω ω')
case (1 j s' y ω'') then show ?case
by (cases ω) (auto split: if_splits)
next
case (2 j x ω' s' ω ω'') then show ?case
by (cases ω) (auto split: if_splits)
qed
next
assume ?cases then show ?merge
proof (split if_split_asm)
assume "trace_in ss t x ω" "t < t'" from this ω' show ?thesis
proof induction
case 1 then show ?case
by (cases ω') auto
qed auto
next
assume "∃y. trace_in {y} t' x ω ∧ trace_in ss t y ω'" "¬ t < t'"
then obtain y where "trace_in {y} t' x ω" "trace_in ss t y ω'" "t' ≤ t"
by auto
from this ω' show ?thesis
by induction auto
qed
qed
lemma AE_lim_wf_times: "AE ω in K.lim_stream (t, s). wf_times t ω"
using AE_lim_stream
proof eventually_elim
fix ω assume *: "∀i. snd (((t, s) ## ω) !! i) ∈ DTMC.acc `` {snd (t, s)} ∧
snd (ω !! i) ∈ J (snd (((t, s) ## ω) !! i)) ∧
fst (((t, s) ## ω) !! i) < fst (ω !! i)"
have "(t ## smap fst ω) !! i < fst (ω !! i)" for i
using *[THEN spec, of i] by (cases i) auto
then show "wf_times t ω"
proof (coinduction arbitrary: t ω)
case wf_times from this[THEN spec, of 0] this[THEN spec, of "Suc i" for i] show ?case
by (cases ω) auto
qed
qed
lemma wf_times_shiftD: "wf_times t' (smap (λ(t', y). (t' + t, y)) ω) ⟹ wf_times (t' - t) ω"
apply (coinduction arbitrary: t' t ω)
subgoal for t' t ω
apply (cases ω; cases "shd ω")
apply (auto simp: )
subgoal for ω' j x
by (rule exI[of _ "j + t"]) auto
done
done
lemma wf_times_shift[simp]: "wf_times t' (smap (λ(t', y). (t' + t, y)) ω) = wf_times (t' - t) ω"
using wf_times_shiftD[of "t' - t" "-t" "smap (λ(t', y). (t' + t, y)) ω"]
by (auto simp: stream.map_comp stream.case_eq_if prod.case_eq_if wf_times_shiftD)
lemma trace_in_unique: "trace_in {y1} t x ω ⟹ trace_in {y2} t x ω ⟹ y1 = y2"
by (induction rule: trace_in.induct) auto
lemma trace_at_eq: "trace_in {z} t x ω ⟹ trace_at x ω t = z"
by (induction rule: trace_in.induct) auto
lemma AE_lim_acc: "AE ω in K.lim_stream (t, x). ∀t z. trace_in {z} t x ω ⟶ (x, z) ∈ DTMC.acc"
using AE_lim_stream
proof (eventually_elim, safe)
fix t' z ω assume *: "∀i. snd (((t, x) ## ω) !! i) ∈ DTMC.acc `` {snd (t, x)} ∧
snd (ω !! i) ∈ J (snd (((t, x) ## ω) !! i)) ∧ fst (((t, x) ## ω) !! i) < fst (ω !! i)"
and t: "trace_in {z} t' x ω"
define X where "X = DTMC.acc `` {x}"
have "(x ## smap snd ω) !! i ∈ X" for i
using *[THEN spec, of i] by (cases i) (auto simp: X_def)
from t this have "z ∈ X"
proof induction
case (1 j y x ω) with "1.prems"[of 0] show ?case
by simp
next
case (2 j y ω x) with "2.prems"[of "Suc i" for i] show ?case
by simp
qed
then show "(x, z) ∈ DTMC.acc"
by (simp add: X_def)
qed
lemma p_add:
assumes "0 ≤ t" "0 ≤ t'"
shows "p x y (t + t') = (LINT z|count_space (DTMC.acc``{x}). p x z t * p z y t')"
proof -
interpret L: prob_space "K.lim_stream xy" for xy
by (rule K.prob_space_lim_stream) simp
interpret A: sigma_finite_measure "count_space (DTMC.acc``{x})"
by (intro sigma_finite_measure_count_space_countable DTMC.countable_acc) simp
interpret LA: pair_sigma_finite "count_space (DTMC.acc``{x})" "K.lim_stream xy" for xy
by unfold_locales
have "p x y (t + t') = (∫⇧+ ω. ∫⇧+ω'. indicator {ω∈space T. trace_in {y} (t + t') x ω} (merge_at ω t ω')
∂K.lim_stream (t, trace_at x ω t) ∂K.lim_stream (0, x))"
unfolding p_def L.emeasure_eq_measure[symmetric]
apply (subst lim_time_split[OF ‹0 ≤ t›])
apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
apply (measurable; fail)
apply (measurable; fail)
apply (intro nn_integral_cong)
apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
apply (measurable; fail)
apply (measurable; fail)
apply (simp add: in_space_lim_stream)
done
also have "… = (∫⇧+ ω. ∫⇧+ω'. indicator {ω∈space T. trace_in {y} (t + t') x ω} (merge_at ω t (smap (λ(t'', s). (t'' + t, s)) ω'))
∂K.lim_stream (0, trace_at x ω t) ∂K.lim_stream (0, x))"
unfolding lim_0[of t] by (subst nn_integral_distr) (measurable; fail)+
also have "… = (∫⇧+ ω. ∫⇧+ω'. of_bool (∃z∈DTMC.acc``{x}. trace_in {z} t x ω ∧ trace_in {y} t' z ω')
∂K.lim_stream (0, trace_at x ω t) ∂K.lim_stream (0, x))"
apply (rule nn_integral_cong_AE)
using AE_lim_wf_times AE_lim_acc
apply eventually_elim
subgoal premises ω for ω
apply (rule nn_integral_cong_AE)
using AE_lim_wf_times AE_lim_acc
apply eventually_elim
using ω assms
apply (auto simp add: trace_in_merge_at indicator_eq_1_iff)
done
done
also have "… = (∫⇧+ ω. ∫⇧+ω'. ∫⇧+z. of_bool (trace_in {z} t x ω ∧ trace_in {y} t' z ω')
∂count_space (DTMC.acc``{x}) ∂K.lim_stream (0, trace_at x ω t) ∂K.lim_stream (0, x))"
by (intro nn_integral_cong of_bool_Bex_eq_nn_integral) (auto dest: trace_in_unique)
also have "… = (∫⇧+ ω. ∫⇧+z. ∫⇧+ω'. of_bool (trace_in {z} t x ω ∧ trace_in {y} t' z ω')
∂K.lim_stream (0, trace_at x ω t) ∂count_space (DTMC.acc``{x}) ∂K.lim_stream (0, x))"
apply (subst LA.Fubini')
apply (subst measurable_split_conv)
apply (rule measurable_compose_countable'[OF _ measurable_fst])
apply (auto simp: DTMC.countable_acc)
done
also have "… = (∫⇧+z. ∫⇧+ ω. of_bool (trace_in {z} t x ω) * ∫⇧+ω'. of_bool (trace_in {y} t' z ω')
∂K.lim_stream (0, z) ∂K.lim_stream (0, x) ∂count_space (DTMC.acc``{x}))"
apply (subst LA.Fubini')
apply (subst measurable_split_conv)
apply (rule measurable_compose_countable'[OF _ measurable_fst])
apply (rule nn_integral_measurable_subprob_algebra2)
apply (measurable; fail)
apply (rule measurable_prob_algebraD)
apply (auto simp: DTMC.countable_acc trace_at_eq intro!: nn_integral_cong)
done
also have "… = (∫⇧+z. (∫⇧+ ω. of_bool (trace_in {z} t x ω)∂K.lim_stream (0, x)) *
(∫⇧+ω'. of_bool (trace_in {y} t' z ω') ∂K.lim_stream (0, z)) ∂count_space (DTMC.acc``{x}))"
by (auto intro!: nn_integral_cong simp: nn_integral_multc)
also have "… = (∫⇧+z. ennreal (p x z t) * ennreal (p z y t') ∂count_space (DTMC.acc``{x}))"
unfolding p_def L.emeasure_eq_measure[symmetric]
by (auto intro!: nn_integral_cong arg_cong2[where f="(*)"]
simp: nn_integral_indicator[symmetric] simp del: nn_integral_indicator )
finally have "(∫⇧+z. p x z t * p z y t' ∂count_space (DTMC.acc``{x})) = p x y (t + t')"
by (simp add: ennreal_mult)
then show ?thesis
by (subst (asm) nn_integral_eq_integrable) auto
qed
end
end
Theory Example_A
theory Example_A
imports "../Classifying_Markov_Chain_States"
begin
section ‹Example A› text_raw ‹\label{ex:A}›
text ‹
We formalize the following Markov chain:
\begin{center}
\begin{tikzpicture}[thick]
\path [fill, color = gray!30] (0, 0) circle(0.6) ;
\path [fill, color = gray!30] (1, 1) circle(0.6) ;
\path [fill, color = gray!30] (4.5, 0.66) ellipse(2 and 1.9) ;
\node (bot) at (-1, 0) {} ;
\node[draw,circle] (A) at (0, 0) {$A$} ;
\node[draw,circle] (B) at (1, 1) {$B$} ;
\node[draw,circle] (C1) at (3, 0) {$C_1$} ;
\node[draw,circle] (C2) at (6, 0) {$C_2$} ;
\node[draw,circle] (C3) at (4.5, 2) {$C_3$} ;
\path[->, >=latex]
(bot) edge (A)
(A) edge node [above] {$\frac{1}{2}$} (B)
edge node [below] {$\frac{1}{2}$} (C1)
(B) edge [loop above] node [left] {$\frac{1}{2}$} (B)
edge [out = 0] node [above] {$\frac{1}{2}$} (C1)
(C1) edge [loop above] node [above] {$\frac{1}{3}$} (C1)
edge [bend left=15] node [above] {$\frac{1}{3}$} (C2)
edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
(C2) edge [loop right] node [above] {$\frac{1}{3}$} (C2)
edge [bend left=15] node [above] {$\frac{1}{3}$} (C1)
edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
(C3) edge [loop right] node [above] {$\frac{1}{2}$} (C3)
edge [bend left=15] node [above] {$\frac{1}{4}$} (C1)
edge [bend left=15] node [above] {$\frac{1}{4}$} (C2) ;
\end{tikzpicture}
\end{center}
First we define the state space as its own type:
›
datatype state = A | B | C1 | C2 | C3
text ‹Now the state space is ‹UNIV :: state set››
lemma UNIV_state: "UNIV = {A, B, C1, C2, C3}"
using state.nchotomy by auto
instance state :: finite
by standard (simp add: UNIV_state)
text ‹The transition function ‹tau› is easily defined using the case statement, this allows
us to give a sparse specification as all ‹0› cases are collected at the end.›
definition tau :: "state ⇒ state ⇒ real" where
"tau s t = (case (s, t) of
(A, B) ⇒ 1 / 2 | (A, C1) ⇒ 1 / 2
| (B, B) ⇒ 1 / 2 | (B, C1) ⇒ 1 / 2
| (C1, C1) ⇒ 1 / 3 | (C1, C2) ⇒ 1 / 3 | (C1, C3) ⇒ 1 / 3
| (C2, C1) ⇒ 1 / 3 | (C2, C2) ⇒ 1 / 3 | (C2, C3) ⇒ 1 / 3
| (C3, C1) ⇒ 1 / 4 | (C3, C2) ⇒ 1 / 4 | (C3, C3) ⇒ 1 / 2
| _ ⇒ 0)"
lift_definition K :: "state ⇒ state pmf" is tau
by (auto simp: tau_def nn_integral_count_space_finite UNIV_state split: state.split simp del: ennreal_plus)
text ‹We use the ‹finite_pmf›-locale which introduces the point measure ‹tau.M›, and
provides us with the necessary simplifier setup.›
interpretation A: MC_syntax K .
subsection ‹The essential classs @{term "{C1, C2, C3}"}›
context
begin
interpretation pmf_as_function .
lemma A_E_eq:
"set_pmf (K x) = (case x of A ⇒ {B, C1} | B ⇒ {B, C1} | _ ⇒ {C1, C2, C3})"
using state.nchotomy by transfer (auto simp: tau_def split: prod.split state.split)
lemma A_essential: "A.essential_class {C1, C2, C3}"
by (rule A.essential_classI2) (auto simp: A_E_eq)
lemma A_aperiodic: "A.aperiodic {C1, C2, C3}"
unfolding A.aperiodic_def
proof safe
have eq: "⋀x'. (if x' = C1 then 1 else 0) = indicator {C1} x'" by auto
show "{C1, C2, C3} ∈ UNIV // A.communicating"
using A_essential by (simp add: A.essential_class_def)
then have "A.period {C1, C2, C3} = Gcd (A.period_set C1)"
by (rule A.period_eq) simp
also have "… = 1"
by (rule Gcd_nat_eq_one) (simp add: A_E_eq A.period_set_def A.p_Suc' A.p_0 eq measure_pmf_single pmf_positive)
finally show "A.period {C1, C2, C3} = 1" .
qed
subsection ‹The stationary distribution ‹n››
text ‹Similar to ‹tau› we introduce ‹n› using the ‹finite_pmf›-locale.›
lift_definition n :: "state pmf" is "λC1 ⇒ 0.3 | C2 ⇒ 0.3 | C3 ⇒ 0.4 | _ ⇒ 0"
by (auto simp: UNIV_state nn_integral_count_space_finite split: state.split)
lemma stationary_distribution_N: "A.stationary_distribution n"
unfolding A.stationary_distribution_def
apply (auto intro!: pmf_eqI simp: pmf_bind integral_measure_pmf[of UNIV])
apply transfer
apply (auto simp: UNIV_state tau_def split: state.split)
done
lemma exclusive_N[simp]: "set_pmf n = {C1, C2, C3}"
using state.nchotomy by transfer (auto split: state.splits)
end
lemma n_is_limit:
assumes x: "x ∈ {C1, C2, C3}" and y: "y ∈ {C1, C2, C3}"
shows "(A.p x y) ⇢ pmf n y"
using A.stationary_distribution_imp_p_limit[OF A_aperiodic A_essential _ stationary_distribution_N _ x y]
by simp
lemma C_is_pos_recurrent: "x ∈ {C1, C2, C3} ⟹ A.pos_recurrent x"
using A.stationary_distributionD(1)[OF A_essential _ stationary_distribution_N] by auto
lemma C_recurrence_time:
assumes x: "x ∈ {C1, C2, C3}"
shows "A.U' x x = 1 / pmf n x"
proof -
from A.stationary_distributionD(2)[OF A_essential _ stationary_distribution_N _]
have "A.stat {C1, C2, C3} = n" by simp
with x have "1 / pmf n x = 1 / emeasure (A.stat {C1, C2, C3}) {x}"
by (simp add: emeasure_pmf_single pmf_positive divide_ennreal ennreal_1[symmetric] del: ennreal_1)
also have "… = A.U' x x"
unfolding A.stat_def using x
by (subst emeasure_point_measure_finite) (simp_all add: A.U'_def)
finally show ?thesis ..
qed
end
Theory Example_B
theory Example_B
imports "../Classifying_Markov_Chain_States"
begin
section ‹Example B› text_raw ‹\label{ex:B}›
text ‹
We now formalize the following Markov chain:
\begin{center}
\begin{tikzpicture}[thick]
\begin{scope} [rotate = 45]
\path [fill, color = gray!30] (7.5, -6) ellipse(3 and 1) ;
\end{scope}
\node (bot2) at (7, -0.5) {} ;
\node[draw, circle] (1) at ( 8, -0.5) {$0$} ;
\node[draw, circle] (2) at ( 9, 0.5) {$1$} ;
\node[draw, circle] (3) at (10, 1.5) {$2$} ;
\node (inft) at (10.7, 2.6) {} ;
\node (infb) at (11, 2) {} ;
\node (inf1) at (10.5, 2) {} ;
\node (inf2) at (11.5, 3) {} ;
\path[->, >=latex]
(bot2) edge (1)
(1) edge [loop below] node [right] {$\frac{2}{3}$} (1)
edge [bend left=30] node [above] {$\frac{1}{3}$} (2)
(2) edge [bend left=30] node [below] {$\frac{2}{3}$} (1)
edge [bend left=30] node [above] {$\frac{1}{3}$} (3)
(3) edge [bend left=30] node [below] {$\frac{2}{3}$} (2)
edge [bend left=30] node [above] {} (inft)
(infb) edge [bend left=30] node [above] {} (3) ;
\path (inf1) edge [loosely dotted] (inf2) ;
\end{tikzpicture}
\end{center}
As state space we have the set of natural numbers, the transition function @{term tau} has three
cases:
›
definition K :: "nat ⇒ nat pmf" where
"K x = map_pmf (λTrue ⇒ x + 1 | False ⇒ x - 1) (bernoulli_pmf (1/3))"
text ‹For the special case when @{term "x = (0::nat)"} we have @{term "x - 1 = (0::nat)"} and hence
@{term "tau 0 0 = 2 / 3"}.›
text ‹We pack this transition function into a discrete Markov kernel.›
text ‹We call the locale of the Markov chain ‹B›, hence all constants and theorems
from this Markov chain get a ‹B› prefix.›
interpretation B: MC_syntax K .
subsection ‹Enabled, accessible and communicating states›
text ‹For each step the predecessor and the successor are enabled (in the @{term 0} case, the
predecessor is again @{term 0}. Hence every state is accessible from everywhere and every states is
communicating with each other state. Finally we know that the state space is an essential class.›
lemma B_E_eq: "set_pmf (K x) = {x - 1, x + 1}"
by (auto simp: set_pmf_bernoulli K_def split: bool.split)
lemma B_E_Suc: "Suc x ∈ set_pmf (K x)" "x ∈ set_pmf (K (Suc x))"
unfolding B_E_eq by auto
lemma B_accessible[intro]: "(i, j) ∈ B.acc"
proof (cases i j rule: linorder_le_cases)
assume "i ≤ j" then show ?thesis
by (induct rule: inc_induct) (auto intro: B_E_Suc converse_rtrancl_into_rtrancl)
next
assume "j ≤ i" then show ?thesis
by (induct rule: dec_induct) (auto intro: B_E_Suc converse_rtrancl_into_rtrancl)
qed
lemma B_communicating[intro]: "(i, j) ∈ B.communicating"
by (simp add: B.communicating_def B_accessible)
lemma B_essential: "B.essential_class UNIV"
by (rule B.essential_classI2) auto
subsection ‹B is aperiodic›
lemma B_aperiodic: "B.aperiodic UNIV"
unfolding B.aperiodic_def
proof safe
have eq: "⋀x'. (if x' = 0 then 1 else 0) = indicator {0} x'" by auto
show "UNIV ∈ UNIV // B.communicating"
using B_essential by (simp add: B.essential_class_def)
then have "B.period UNIV = Gcd (B.period_set 0)"
by (rule B.period_eq) simp
also have "… = 1"
by (rule Gcd_nat_eq_one) (simp add: B.period_set_def B.p_Suc' B.p_0 eq measure_pmf_single pmf_positive_iff K_def set_pmf_bernoulli UNIV_bool)
finally show "B.period UNIV = 1" .
qed
subsection ‹The stationary distribution ‹N››
abbreviation N :: "nat pmf" where
"N ≡ geometric_pmf (1 / 2)"
lemma stationary_distribution_N: "B.stationary_distribution N"
unfolding B.stationary_distribution_def
proof (rule pmf_eqI)
fix a show "pmf N a = pmf (bind_pmf N K) a"
apply (simp add: pmf_bind K_def map_pmf_def)
apply (subst integral_measure_pmf[of "{a - 1, a + 1}"])
apply (auto split: split_indicator_asm nat.splits simp: minus_nat.diff_Suc)
done
qed
subsection ‹Limit behavior and recurrence times›
lemma limit: "(B.p i j) ⇢ (1/2)^Suc j"
proof -
have "B.p i j ⇢ pmf N j"
by (rule B.stationary_distribution_imp_p_limit[OF B_aperiodic B_essential _ stationary_distribution_N])
auto
then show ?thesis
by (simp add: ac_simps)
qed
lemma pos_recurrent: "B.pos_recurrent i"
using B.stationary_distributionD(1)[OF B_essential _ stationary_distribution_N _] by auto
lemma recurrence_time: "B.U' i i = 2^Suc i"
proof -
have "B.stat UNIV = N"
using B.stationary_distributionD(2)[OF B_essential _ stationary_distribution_N _] by simp
then have "2^Suc i = 1 / emeasure (B.stat UNIV) {i}"
apply (simp add: field_simps emeasure_pmf_single pmf_positive)
apply (subst divide_ennreal[symmetric])
apply (auto simp: ennreal_mult ennreal_power[symmetric])
done
also have "… = B.U' i i"
unfolding B.stat_def
by (subst emeasure_point_measure_finite2)
(simp_all add: B.U'_def)
finally show ?thesis
by simp
qed
end
Theory PCTL
theory PCTL
imports
"../Discrete_Time_Markov_Chain"
"Gauss-Jordan-Elim-Fun.Gauss_Jordan_Elim_Fun"
"HOL-Library.While_Combinator"
"HOL-Library.Monad_Syntax"
begin
section ‹Adapt Gauss-Jordan elimination to DTMCs›
locale Finite_DTMC =
fixes K :: "'s ⇒ 's pmf" and S :: "'s set" and ρ :: "'s ⇒ real" and ι :: "'s ⇒ 's ⇒ real"
assumes ι_nonneg[simp]: "⋀s t. 0 ≤ ι s t" and ρ_nonneg[simp]: "⋀s. 0 ≤ ρ s"
assumes measurable_ι: "(λ(a, b). ι a b) ∈ borel_measurable (count_space UNIV ⨂⇩M count_space UNIV)"
assumes finite_S[simp]: "finite S" and S_not_empty: "S ≠ {}"
assumes E_closed: "(⋃s∈S. set_pmf (K s)) ⊆ S"
begin
lemma measurable_ι'[measurable (raw)]:
"f ∈ measurable M (count_space UNIV) ⟹ g ∈ measurable M (count_space UNIV) ⟹
(λx. ι (f x) (g x)) ∈ borel_measurable M"
using measurable_compose[OF _ measurable_ι, of "λx. (f x, g x)" M] by simp
lemma measurable_ρ[measurable]: "ρ ∈ borel_measurable (count_space UNIV)"
by simp
sublocale R?: MC_with_rewards K ι ρ
by standard (auto intro: ι_nonneg ρ_nonneg)
lemma single_l:
fixes s and x :: real assumes "s ∈ S"
shows "(∑s'∈S. (if s' = s then 1 else 0) * l s') = x ⟷ l s = x"
by (simp add: assms if_distrib [of "λx. x * a" for a] cong: if_cong)
definition "order = (SOME f. bij_betw f {..< card S} S)"
lemma
shows bij_order[simp]: "bij_betw order {..< card S} S"
and inj_order[simp]: "inj_on order {..<card S}"
and image_order[simp]: "order ` {..<card S} = S"
and order_S[simp, intro]: "⋀i. i < card S ⟹ order i ∈ S"
proof -
from finite_same_card_bij[OF _ finite_S] show "bij_betw order {..< card S} S"
unfolding order_def by (rule someI_ex) auto
then show "inj_on order {..<card S}" "order ` {..<card S} = S"
unfolding bij_betw_def by auto
then show "⋀i. i < card S ⟹ order i ∈ S"
by auto
qed
lemma order_Ex:
assumes "s ∈ S" obtains i where "i < card S" "s = order i"
proof -
from ‹s ∈ S› have "s ∈ order ` {..<card S}"
by simp
with that show thesis
by (auto simp del: image_order)
qed
definition "iorder = the_inv_into {..<card S} order"
lemma bij_iorder: "bij_betw iorder S {..<card S}"
unfolding iorder_def by (rule bij_betw_the_inv_into bij_order)+
lemma iorder_image_eq: "iorder ` S = {..<card S}"
and inj_iorder: "inj_on iorder S"
using bij_iorder unfolding bij_betw_def by auto
lemma order_iorder: "⋀s. s ∈ S ⟹ order (iorder s) = s"
unfolding iorder_def using bij_order
by (intro f_the_inv_into_f) (auto simp: bij_betw_def)
definition gauss_jordan' :: "('s ⇒ 's ⇒ real) ⇒ ('s ⇒ real) ⇒ ('s ⇒ real) option" where
"gauss_jordan' M a = do {
let M' = (λi j. if j = card S then a (order i) else M (order i) (order j)) ;
sol ← gauss_jordan M' (card S) ;
Some (λi. sol (iorder i) (card S))
}"
lemma gauss_jordan'_correct:
assumes "gauss_jordan' M a = Some f"
shows "∀s∈S. (∑s'∈S. M s s' * f s') = a s"
proof -
note ‹gauss_jordan' M a = Some f›
moreover define M' where "M' = (λi j. if j = card S then
a (order i) else M (order i) (order j))"
ultimately obtain sol where sol: "gauss_jordan M' (card S) = Some sol"
and f: "f = (λi. sol (iorder i) (card S))"
by (auto simp: gauss_jordan'_def Let_def split: bind_split_asm)
from gauss_jordan_correct[OF sol]
have "∀i∈{..<card S}. (∑j<card S. M (order i) (order j) * sol j (card S)) = a (order i)"
unfolding solution_def M'_def by (simp add: atLeast0LessThan)
then show ?thesis
unfolding iorder_image_eq[symmetric] f using inj_iorder
by (subst (asm) sum.reindex) (auto simp: order_iorder)
qed
lemma gauss_jordan'_complete:
assumes exists: "∀s∈S. (∑s'∈S. M s s' * x s') = a s"
assumes unique: "⋀y. ∀s∈S. (∑s'∈S. M s s' * y s') = a s ⟹ ∀s∈S. y s = x s"
shows "∃y. gauss_jordan' M a = Some y"
proof -
define M' where "M' = (λi j. if j = card S then
a (order i) else M (order i) (order j))"
{ fix x
have iorder_neq_card_S: "⋀s. s ∈ S ⟹ iorder s ≠ card S"
using iorder_image_eq by (auto simp: set_eq_iff less_le)
have "solution2 M' (card S) (card S) x ⟷
(∀s∈{..<card S}. (∑s'∈{..<card S}. M' s s' * x s') = M' s (card S))"
unfolding solution2_def by (auto simp: atLeast0LessThan)
also have "… ⟷ (∀s∈S. (∑s'∈S. M s s' * x (iorder s')) = a s)"
unfolding iorder_image_eq[symmetric] M'_def
using inj_iorder iorder_neq_card_S
by (simp add: sum.reindex order_iorder)
finally have "solution2 M' (card S) (card S) x ⟷
(∀s∈S. (∑s'∈S. M s s' * x (iorder s')) = a s)" . }
note sol2_eq = this
have "usolution M' (card S) (card S) (λi. x (order i))"
unfolding usolution_def
proof safe
from exists show "solution2 M' (card S) (card S) (λi. x (order i))"
by (simp add: sol2_eq order_iorder)
next
fix y j assume y: "solution2 M' (card S) (card S) y" and "j < card S"
then have "∀s∈S. (∑s'∈S. M s s' * y (iorder s')) = a s"
by (simp add: sol2_eq)
from unique[OF this]
have "∀i∈{..<card S}. y i = x (order i)"
unfolding iorder_image_eq[symmetric]
by (simp add: order_iorder)
with ‹j < card S› show "y j = x (order j)" by simp
qed
from gauss_jordan_complete[OF _ this]
show ?thesis
by (auto simp: gauss_jordan'_def simp: M'_def)
qed
end
section ‹pCTL model checking›
subsection ‹Syntax›
datatype realrel = LessEqual | Less | Greater | GreaterEqual | Equal
datatype 's sform = "true"
| "Label" "'s set"
| "Neg" "'s sform"
| "And" "'s sform" "'s sform"
| "Prob" "realrel" "real" "'s pform"
| "Exp" "realrel" "real" "'s eform"
and 's pform = "X" "'s sform"
| "U" "nat" "'s sform" "'s sform"
| "UInfinity" "'s sform" "'s sform" ("U⇧∞")
and 's eform = "Cumm" "nat" ("C⇧≤")
| "State" "nat" ("I⇧=")
| "Future" "'s sform"
primrec bound_until where
"bound_until 0 φ ψ = ψ"
| "bound_until (Suc n) φ ψ = ψ or (φ aand nxt (bound_until n φ ψ))"
lemma measurable_bound_until[measurable]:
assumes [measurable]: "Measurable.pred (stream_space M) φ" "Measurable.pred (stream_space M) ψ"
shows "Measurable.pred (stream_space M) (bound_until n φ ψ)"
by (induct n) simp_all
subsection ‹Semantics›
primrec inrealrel :: "realrel ⇒ 'a ⇒ ('a::linorder) ⇒ bool" where
"inrealrel LessEqual r q ⟷ q ≤ r" |
"inrealrel Less r q ⟷ q < r" |
"inrealrel Greater r q ⟷ q > r" |
"inrealrel GreaterEqual r q ⟷ q ≥ r" |
"inrealrel Equal r q ⟷ q = r"
context Finite_DTMC
begin
abbreviation "prob s P ≡ measure (T s) {x∈space (T s). P x}"
abbreviation "E s ≡ set_pmf (K s)"
primrec svalid :: "'s sform ⇒ 's set"
and pvalid :: "'s pform ⇒ 's stream ⇒ bool"
and reward :: "'s eform ⇒ 's stream ⇒ ennreal" where
"svalid true = S" |
"svalid (Label L) = {s ∈ S. s ∈ L}" |
"svalid (Neg F) = S - svalid F" |
"svalid (And F1 F2) = svalid F1 ∩ svalid F2" |
"svalid (Prob rel r F) = {s ∈ S. inrealrel rel r 𝒫(ω in T s. pvalid F (s ## ω)) }" |
"svalid (Exp rel r F) = {s ∈ S. inrealrel rel (ennreal r) (∫⇧+ ω. reward F (s ## ω) ∂T s) }" |
"pvalid (X F) = nxt (HLD (svalid F))" |
"pvalid (U k F1 F2) = bound_until k (HLD (svalid F1)) (HLD (svalid F2))" |
"pvalid (U⇧∞ F1 F2) = HLD (svalid F1) suntil HLD (svalid F2)" |
"reward (C⇧≤ k) = (λω. (∑i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))))" |
"reward (I⇧= k) = (λω. ρ (ω !! k))" |
"reward (Future F) = (λω. if ev (HLD (svalid F)) ω then reward_until (svalid F) (shd ω) (stl ω) else ∞)"
lemma svalid_subset_S: "svalid F ⊆ S"
by (induct F) auto
lemma finite_svalid[simp, intro]: "finite (svalid F)"
using svalid_subset_S finite_S by (blast intro: finite_subset)
lemma svalid_sets[measurable]: "svalid F ∈ sets (count_space S)"
using svalid_subset_S by auto
lemma pvalid_sets[measurable]: "Measurable.pred R.S (pvalid F)"
by (cases F) (auto intro!: svalid_sets)
lemma reward_measurable[measurable]: "reward F ∈ borel_measurable R.S"
by (cases F) auto
subsection ‹Implementation of ‹Sat››
subsubsection ‹‹Prob0››
definition Prob0 where
"Prob0 Φ Ψ = S - while (λR. ∃s∈Φ. R ∩ E s ≠ {} ∧ s ∉ R) (λR. R ∪ {s∈Φ. R ∩ E s ≠ {}}) Ψ"
lemma Prob0_subset_S: "Prob0 Φ Ψ ⊆ S"
unfolding Prob0_def by auto
lemma Prob0_iff_reachable:
assumes "Φ ⊆ S" "Ψ ⊆ S"
shows "Prob0 Φ Ψ = {s ∈ S. ((SIGMA x:Φ. E x)⇧* `` {s}) ∩ Ψ = {}}" (is "_ = ?U")
unfolding Prob0_def
proof (intro while_rule[where Q="λR. S - R = ?U" and P="λR. Ψ ⊆ R ∧ R ⊆ S - ?U"] conjI)
show "wf {(B, A). A ⊂ B ∧ B ⊆ S}"
by (rule wf_bounded_set[where ub="λ_. S" and f="λx. x"]) auto
show "Ψ ⊆ S - ?U"
using assms by auto
let ?Δ = "λR. {s∈Φ. R ∩ E s ≠ {}}"
{ fix R assume R: "Ψ ⊆ R ∧ R ⊆ S - ?U" and "∃s∈Φ. R ∩ E s ≠ {} ∧ s ∉ R"
with assms show "(R ∪ ?Δ R, R) ∈ {(B, A). A ⊂ B ∧ B ⊆ S}" "Ψ ⊆ R ∪ ?Δ R"
by auto
{ fix s s' assume s: "s ∈ Φ" "s' ∈ R" "s' ∈ E s" and r: "(Sigma Φ E)⇧* `` {s} ∩ Ψ = {}"
with R have "(s, s') ∈ (Sigma Φ E)⇧*" "s' ∈ Φ - Ψ"
by (auto elim: converse_rtranclE)
moreover with ‹s' ∈ R› R obtain s'' where "(s', s'') ∈ (Sigma Φ E)⇧*" "s'' ∈ Ψ"
by auto
ultimately have "(s, s'') ∈ (Sigma Φ E)⇧*" "s'' ∈ Ψ"
by auto
with r have False
by auto }
with ‹Φ ⊆ S› R show "R ∪ ?Δ R ⊆ S - ?U" by auto }
{ fix R assume R: "Ψ ⊆ R ∧ R ⊆ S - ?U" and dR: "¬ (∃s∈Φ. R ∩ E s ≠ {} ∧ s ∉ R)"
{ fix s t assume s: "s ∈ S - R"
assume s_t: "(s, t) ∈ (Sigma Φ E)⇧*" then have "t ∈ S - R"
proof induct
case (step t u) with R dR E_closed show ?case
by auto
qed fact
then have "t ∉ Ψ"
using R by auto }
with R show "S - R = ?U"
by auto }
qed rule
lemma Prob0_iff:
assumes "Φ ⊆ S" "Ψ ⊆ S"
shows "Prob0 Φ Ψ = {s∈S. AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)}" (is "_ = ?U")
unfolding Prob0_iff_reachable[OF assms]
proof (intro Collect_cong conj_cong refl iffI)
fix s assume s: "s ∈ S" "(Sigma Φ E)⇧* `` {s} ∩ Ψ = {}"
{ fix ω assume "(HLD Φ suntil HLD Ψ) ω" "enabled (shd ω) (stl ω)" "(Sigma Φ E)⇧* `` {shd ω} ∩ Ψ = {}"
from this have False
proof induction
case (step ω)
moreover
then have "(shd ω, shd (stl ω)) ∈ (Sigma Φ E)⇧*"
by (auto simp: enabled.simps[of _ "stl ω"] HLD_iff)
then have "(Sigma Φ E)⇧* `` {shd (stl ω)} ⊆ (Sigma Φ E)⇧* `` {shd ω}"
by auto
ultimately show ?case
by (auto simp add: enabled.simps[of _ "stl ω"])
qed (auto simp: HLD_iff) }
from s this[of "s ## ω" for ω] show "AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)"
using AE_T_enabled[of s] by auto
next
fix s assume s: "AE ω in T s. ¬ (HLD Φ suntil HLD Ψ) (s ## ω)"
{ fix t assume "(s, t) ∈ (Sigma Φ E)⇧*" from this s have "t ∉ Ψ"
proof (induction rule: converse_rtrancl_induct)
case (step s u) then show ?case
by (simp add: AE_T_iff[where x=s] suntil_Stream[of _ _ s])
qed (simp add: suntil_Stream) }
then show "(Sigma Φ E)⇧* `` {s} ∩ Ψ = {}"
by auto
qed
lemma E_rtrancl_closed:
assumes "s ∈ S" "(s, t) ∈ (SIGMA x:A. B x)⇧*" "⋀x. x ∈ A ⟹ B x ⊆ E x" shows "t ∈ S"
using assms(2,3,1) E_closed by induction force+
subsubsection ‹‹Prob1››
definition Prob1 where
"Prob1 Y Φ Ψ = Prob0 (Φ - Ψ) Y"
lemma Prob1_iff:
assumes "Φ ⊆ S" "Ψ ⊆ S"
shows "Prob1 (Prob0 Φ Ψ) Φ Ψ = {s∈S. AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)}"
(is "Prob1 ?P0 _ _ = {s∈S. ?pU s}")
proof -
note P0 = Prob0_iff_reachable[OF assms]
have *: "Φ - Ψ ⊆ S" "?P0 ⊆ S"
using P0 assms by auto
have P0_subset: "S - Φ - Ψ ⊆ ?P0"
unfolding P0 by (auto elim: converse_rtranclE)
have "Prob1 ?P0 Φ Ψ = {s ∈ S. (Sigma (Φ - Ψ) E)⇧* `` {s} ∩ ?P0 = {}}"
unfolding Prob0_iff_reachable[OF *] Prob1_def ..
also have "… = {s∈S. AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)}"
proof (intro Collect_cong conj_cong refl iffI)
fix s assume s: "s ∈ S" "(Sigma (Φ - Ψ) E)⇧* `` {s} ∩ ?P0 = {}"
then have "s ∉ ?P0"
by auto
then have "s ∈ Φ - Ψ ∨ s ∈ Ψ"
using P0_subset ‹s ∈ S› by auto
moreover
{ assume "s ∈ Φ - Ψ"
have "AE ω in T s. ev (HLD (Ψ ∪ ?P0)) ω"
proof (rule AE_T_ev_HLD)
fix t assume s_t: "(s, t) ∈ acc_on (- (Ψ ∪ ?P0))"
from ‹s ∈ S› s_t have "t ∈ S"
by (rule E_rtrancl_closed) auto
show "∃t'∈Ψ ∪ ?P0. (t, t') ∈ acc"
proof cases
assume "t ∈ ?P0" then show ?thesis by auto
next
assume "t ∉ ?P0"
with ‹t∈S› obtain s where t_s: "(t, s) ∈ (SIGMA x:Φ. E x)⇧*" and "s ∈ Ψ"
unfolding P0 by auto
from t_s have "(t, s) ∈ acc"
by (rule rev_subsetD) (intro rtrancl_mono Sigma_mono, auto)
with ‹s ∈ Ψ› show ?thesis by auto
qed
next
have "acc_on (- (Ψ ∪ ?P0)) `` {s} ⊆ S"
using ‹s ∈ S› by (auto intro: E_rtrancl_closed)
then show "finite (acc_on (- (Ψ ∪ ?P0)) `` {s})"
using finite_S by (auto dest: finite_subset)
qed
then have "AE ω in T s. (HLD Φ suntil HLD Ψ) ω"
using AE_T_enabled
proof eventually_elim
fix ω assume "ev (HLD (Ψ ∪ ?P0)) ω" "enabled s ω"
from this s ‹s ∈ Φ - Ψ› show "(HLD Φ suntil HLD Ψ) ω"
proof (induction arbitrary: s)
case (base ω) then show ?case
by (auto simp: HLD_iff enabled.simps[of s] intro: suntil.intros)
next
case (step ω)
then have "(s, shd ω) ∈ (Sigma (Φ - Ψ) E)"
by (auto simp: enabled.simps[of s])
then have *: "(Sigma (Φ - Ψ) E)⇧* `` {shd ω} ∩ ?P0 = {}"
using step.prems by (auto intro: converse_rtrancl_into_rtrancl)
then have "shd ω ∈ Φ - Ψ ∨ shd ω ∈ Ψ" "shd ω ∈ S"
using P0_subset step.prems(1,2) E_closed by (auto simp add: enabled.simps[of s])
then show ?case
using step.prems(1) step.IH[OF _ _ *] ‹shd ω ∈ S›
by (auto simp add: suntil.simps[of _ _ ω] HLD_iff[abs_def] enabled.simps[of s ω])
qed
qed }
ultimately show "AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)"
by (cases "s ∈ Φ - Ψ") (auto simp add: suntil_Stream)
next
fix s assume s: "s ∈ S" "AE ω in T s. (HLD Φ suntil HLD Ψ) (s ## ω)"
{ fix t assume "(s, t) ∈ (SIGMA s:Φ-Ψ. E s)⇧*"
from this ‹s ∈ S› have "(AE ω in T t. (HLD Φ suntil HLD Ψ) (t ## ω)) ∧ t ∈ S"
proof induction
case (step t u) with E_closed show ?case
by (auto simp add: AE_T_iff[of _ t] suntil_Stream)
qed (insert s, auto)
then have "t ∉ ?P0"
unfolding Prob0_iff[OF assms] by (auto dest: T.AE_contr) }
then show "(Sigma (Φ - Ψ) E)⇧* `` {s} ∩ Prob0 Φ Ψ = {}"
by auto
qed
finally show ?thesis .
qed
subsubsection ‹‹ProbU›, ‹ExpCumm›, and ‹ExpState››
abbreviation "τ s t ≡ pmf (K s) t"
fun ProbU :: "'s ⇒ nat ⇒ 's set ⇒ 's set ⇒ real" where
"ProbU q 0 S1 S2 = (if q ∈ S2 then 1 else 0)" |
"ProbU q (Suc k) S1 S2 =
(if q ∈ S1 - S2 then (∑q'∈S. τ q q' * ProbU q' k S1 S2)
else if q ∈ S2 then 1 else 0)"
fun ExpCumm :: "'s ⇒ nat ⇒ ennreal" where
"ExpCumm s 0 = 0" |
"ExpCumm s (Suc k) = ρ s + (∑s'∈S. τ s s' * (ι s s' + ExpCumm s' k))"
fun ExpState :: "'s ⇒ nat ⇒ ennreal" where
"ExpState s 0 = ρ s" |
"ExpState s (Suc k) = (∑s'∈S. τ s s' * ExpState s' k)"
subsubsection ‹‹LES››
definition LES :: "'s set ⇒ 's ⇒ 's ⇒ real" where
"LES F r c =
(if r ∈ F then (if c = r then 1 else 0)
else (if c = r then τ r c - 1 else τ r c ))"
subsubsection ‹‹ProbUinfty›, compute unbounded until›
definition ProbUinfty :: "'s set ⇒ 's set ⇒ ('s ⇒ real) option" where
"ProbUinfty S1 S2 = gauss_jordan' (LES (Prob0 S1 S2 ∪ S2))
(λi. if i ∈ S2 then 1 else 0)"
subsubsection ‹‹ExpFuture›, compute unbounded reward›
definition ExpFuture :: "'s set ⇒ ('s ⇒ ennreal) option" where
"ExpFuture F = do {
let N = Prob0 S F ;
let Y = Prob1 N S F ;
sol ← gauss_jordan' (LES (S - Y ∪ F))
(λi. if i ∈ Y ∧ i ∉ F then - ρ i - (∑s'∈S. τ i s' * ι i s') else 0) ;
Some (λs. if s ∈ Y then ennreal (sol s) else ∞)
}"
subsubsection ‹‹Sat››
fun Sat :: "'s sform ⇒ 's set option" where
"Sat true = Some S" |
"Sat (Label L) = Some {s ∈ S. s ∈ L}" |
"Sat (Neg F) = do { F ← Sat F ; Some (S - F) }" |
"Sat (And F1 F2) = do { F1 ← Sat F1 ; F2 ← Sat F2 ; Some (F1 ∩ F2) }" |
"Sat (Prob rel r (X F)) = do { F ← Sat F ; Some {q ∈ S. inrealrel rel r (∑q'∈F. τ q q')} }" |
"Sat (Prob rel r (U k F1 F2)) = do { F1 ← Sat F1 ; F2 ← Sat F2 ; Some {q ∈ S. inrealrel rel r (ProbU q k F1 F2) } }" |
"Sat (Prob rel r (U⇧∞ F1 F2)) = do { F1 ← Sat F1 ; F2 ← Sat F2 ; P ← ProbUinfty F1 F2 ; Some {q ∈ S. inrealrel rel r (P q) } }" |
"Sat (Exp rel r (Cumm k)) = Some {s ∈ S. inrealrel rel r (ExpCumm s k) }" |
"Sat (Exp rel r (State k)) = Some {s ∈ S. inrealrel rel r (ExpState s k) }" |
"Sat (Exp rel r (Future F)) = do { F ← Sat F ; E ← ExpFuture F ; Some {q ∈ S. inrealrel rel (ennreal r) (E q) } }"
lemma prob_sum:
"s ∈ S ⟹ Measurable.pred R.S P ⟹ 𝒫(ω in T s. P ω) = (∑t∈S. τ s t * 𝒫(ω in T t. P (t ## ω)))"
unfolding prob_T using E_closed by (subst integral_measure_pmf[OF finite_S]) (auto simp: mult.commute)
lemma nn_integral_eq_sum:
"s ∈ S ⟹ f ∈ borel_measurable R.S ⟹ (∫⇧+x. f x ∂T s) = (∑t∈S. τ s t * (∫⇧+x. f (t ## x) ∂T t))"
unfolding nn_integral_T using E_closed
by (subst nn_integral_measure_pmf_support[OF finite_S])
(auto simp: mult.commute)
lemma T_space[simp]: "measure (T s) (space R.S) = 1"
using T.prob_space by simp
lemma emeasure_T_space[simp]: "emeasure (T s) (space R.S) = 1"
using T.emeasure_space_1 by simp
lemma τ_distr[simp]: "s ∈ S ⟹ (∑t∈S. τ s t) = 1"
using prob_sum[of s "λ_. True"] by simp
lemma ProbU:
"q ∈ S ⟹ ProbU q k (svalid F1) (svalid F2) = 𝒫(ω in T q. pvalid (U k F1 F2) (q ## ω))"
proof (induct k arbitrary: q)
case 0 with T.prob_space show ?case by simp
next
case (Suc k)
have "𝒫(ω in T q. pvalid (U (Suc k) F1 F2) (q ## ω)) =
(if q ∈ svalid F2 then 1 else if q ∈ svalid F1 then
∑t∈S. τ q t * 𝒫(ω in T t. pvalid (U k F1 F2) (t ## ω)) else 0)"
using ‹q ∈ S› by (subst prob_sum) simp_all
also have "… = ProbU q (Suc k) (svalid F1) (svalid F2)"
using Suc by simp
finally show ?case ..
qed
lemma Prob0_imp_not_Psi:
assumes "Φ ⊆ S" "Ψ ⊆ S" "s ∈ Prob0 Φ Ψ" shows "s ∉ Ψ"
proof -
have "s ∈ S" using ‹s ∈ Prob0 Φ Ψ› Prob0_subset_S by auto
with assms show ?thesis by (auto simp add: Prob0_iff suntil_Stream)
qed
lemma Psi_imp_not_Prob0:
assumes "Φ ⊆ S" "Ψ ⊆ S" shows "s ∈ Ψ ⟹ s ∉ Prob0 Φ Ψ"
using Prob0_imp_not_Psi[OF assms] by metis
subsubsection ‹Finite expected reward›
abbreviation "s0 ≡ SOME s. s ∈ S"
lemma s0_in_S: "s0 ∈ S"
using S_not_empty by (auto intro!: someI_ex[of "λx. x ∈ S"])
lemma nn_integral_reward_finite:
assumes "s ∈ S"
assumes until: "AE ω in T s. (HLD S suntil HLD (svalid F)) (s ## ω)"
shows "(∫⇧+ ω. reward (Future F) (s ## ω) ∂T s) ≠ ∞"
proof -
have "(∫⇧+ ω. reward (Future F) (s ## ω) ∂T s) = (∫⇧+ ω. reward_until (svalid F) s ω ∂T s)"
using until by (auto intro!: nn_integral_cong_AE ev_suntil)
also have "… ≠ ∞"
proof cases
assume "s ∉ svalid F"
show ?thesis
proof (rule nn_integral_reward_until_finite)
have "acc `` {s} ⊆ S"
using E_rtrancl_closed[of s _ _ E] ‹s ∈ S› by auto
then show "finite (acc `` {s})"
using finite_S by (auto dest: finite_subset)
show "AE ω in T s. (ev (HLD (svalid F))) ω"
using until by (auto simp add: suntil_Stream ‹s ∉ svalid F› intro: ev_suntil)
qed auto
qed simp
finally show ?thesis .
qed
lemma unique:
assumes in_S: "Φ ⊆ S" "Ψ ⊆ S" "N ⊆ S" "Prob0 Φ Ψ ⊆ N" "Ψ ⊆ N"
assumes l1: "⋀s. s ∈ S ⟹ s ∉ N ⟹ l1 s - c s = (∑s'∈S. τ s s' * l1 s')"
assumes l2: "⋀s. s ∈ S ⟹ s ∉ N ⟹ l2 s - c s = (∑s'∈S. τ s s' * l2 s')"
assumes eq: "⋀s. s ∈ N ⟹ l1 s = l2 s"
shows "∀s∈S. l1 s = l2 s"
proof
fix s assume "s ∈ S"
show "l1 s = l2 s"
proof cases
assume "s ∈ N" then show ?thesis
by (rule eq)
next
assume "s ∉ N"
show ?thesis
proof (rule unique_les[of _ "S - N" K N])
show "finite ((λx. l1 x - l2 x) ` (S - N ∪ N))" "(⋃x∈S - N. E x) ⊆ S - N ∪ N"
using E_closed finite_S ‹N ⊆ S› by (auto dest: finite_subset)
show "⋀s. s ∈ N ⟹ l1 s = l2 s" by fact
{ fix s assume "s ∈ S - N" with E_closed finite_S show "integrable (K s) l1" "integrable (K s) l2"
by (auto intro!: integrable_measure_pmf_finite dest: finite_subset)
obtain t where "(t ∈ Ψ ∧ (s, t) ∈ (Sigma Φ E)⇧*) ∨ s ∈ N"
using ‹s ∈ S - N› in_S(4) unfolding Prob0_iff_reachable[OF in_S(1,2)] by auto
moreover have "(Sigma Φ E)⇧* ⊆ acc"
by (intro rtrancl_mono Sigma_mono) auto
ultimately show "∃t∈N. (s, t) ∈ acc"
using ‹Ψ ⊆ N› by auto
show "l1 s = integral⇧L (K s) l1 + c s"
using E_closed l1 ‹s ∈ S - N›
by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps)
show "l2 s = integral⇧L (K s) l2 + c s"
using E_closed l2 ‹s ∈ S - N›
by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps) }
qed (insert ‹s ∉ N› ‹s ∈ S›, auto)
qed
qed
lemma uniqueness_of_ProbU:
assumes sol:
"∀s∈S. (∑s'∈S. LES (Prob0 (svalid F1) (svalid F2) ∪ svalid F2) s s' * l s') =
(if s ∈ svalid F2 then 1 else 0)"
shows "∀s∈S. l s = 𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω))"
proof (rule unique)
show "svalid F1 ⊆ S" "svalid F2 ⊆ S"
"Prob0 (svalid F1) (svalid F2) ⊆ Prob0 (svalid F1) (svalid F2) ∪ svalid F2"
"svalid F2 ⊆ Prob0 (svalid F1) (svalid F2) ∪ svalid F2"
"Prob0 (svalid F1) (svalid F2) ∪ svalid F2 ⊆ S"
using svalid_subset_S by (auto simp: Prob0_def)
next
fix s assume s: "s ∈ S" "s ∉ Prob0 (svalid F1) (svalid F2) ∪ svalid F2"
have "(∑s'∈S. (if s' = s then τ s s' - 1 else τ s s') * l s') =
(∑s'∈S. τ s s' * l s' - (if s' = s then 1 else 0) * l s')"
by (auto intro!: sum.cong simp: field_simps)
also have "… = (∑s'∈S. τ s s' * l s') - l s"
using ‹s ∈ S› by (simp add: sum_subtractf single_l)
finally show "l s - 0 = (∑s'∈S. τ s s' * l s')"
using sol[THEN bspec, of s] s by (simp add: LES_def)
next
fix s assume s: "s ∈ S" "s ∉ Prob0 (svalid F1) (svalid F2) ∪ svalid F2"
then show "𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω)) - 0 =
(∑t∈S. τ s t * 𝒫(ω in T t. pvalid (U⇧∞ F1 F2) (t ## ω)))"
unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S]
by (subst prob_sum) (auto simp add: suntil_Stream)
next
fix s assume "s ∈ Prob0 (svalid F1) (svalid F2) ∪ svalid F2"
then show "l s = 𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω))"
proof
assume P0: "s ∈ Prob0 (svalid F1) (svalid F2)"
then have "s ∈ S" "AE ω in T s. ¬ (HLD (svalid F1) suntil HLD (svalid F2)) (s ## ω)"
unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S] by auto
then have "𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω)) = 0"
by (intro T.prob_eq_0_AE) simp
moreover have "l s = 0"
using ‹s ∈ S› P0 sol[THEN bspec, of s] Prob0_subset_S
Prob0_imp_not_Psi[OF svalid_subset_S svalid_subset_S P0]
by (auto simp: LES_def single_l split: if_split_asm)
ultimately show "l s = 𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω))" by simp
next
assume s: "s ∈ svalid F2"
moreover with svalid_subset_S have "s ∈ S" by auto
moreover note Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S s]
ultimately have "l s = 1"
using sol[THEN bspec, of s]
by (auto simp: LES_def single_l dest: Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S])
then show "l s = 𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω))"
using s by (simp add: suntil_Stream)
qed
qed
lemma infinite_reward:
fixes s F
defines "N ≡ Prob0 S (svalid F)" (is "_ ≡ Prob0 S ?F")
defines "Y ≡ Prob1 N S (svalid F)"
assumes s: "s ∈ S" "s ∉ Y"
shows "(∫⇧+ω. reward (Future F) (s ## ω) ∂T s) = ∞"
proof -
{ assume "(AE ω in T s. ev (HLD ?F) ω)"
with AE_T_enabled have "(AE ω in T s. (HLD S suntil HLD ?F) ω)"
proof eventually_elim
fix ω assume "ev (HLD ?F) ω" "enabled s ω"
from this ‹s ∈ S› show "(HLD S suntil HLD ?F) ω"
proof (induction arbitrary: s)
case (step ω) show ?case
using E_closed step.IH[of "shd ω"] step.prems
by (auto simp: subset_eq enabled.simps[of s] suntil.simps[of _ _ ω] HLD_iff)
qed (auto intro: suntil.intros)
qed }
moreover have "¬ (AE ω in T s. (HLD S suntil HLD ?F) (s ## ω))"
using s svalid_subset_S unfolding N_def Y_def by (simp add: Prob1_iff)
ultimately have *: "¬ (AE ω in T s. ev (HLD ?F) (s ## ω))"
using ‹s ∈ S› by (cases "s ∈ ?F") (auto simp add: suntil_Stream ev_Stream)
show ?thesis
proof (rule ccontr)
assume "¬ ?thesis"
from nn_integral_PInf_AE[OF _ this] ‹s∈S›
have "AE ω in T s. ev (HLD ?F) (s ## ω)"
by (simp split: if_split_asm)
with * show False ..
qed
qed
subsubsection ‹The expected reward implies a unique LES›
lemma existence_of_ExpFuture:
fixes s F
assumes N_def: "N ≡ Prob0 S (svalid F)" (is "_ ≡ Prob0 S ?F")
assumes Y_def: "Y ≡ Prob1 N S (svalid F)"
assumes s: "s ∈ S" "s ∉ S - (Y - ?F)"
shows "enn2real (∫⇧+ω. reward (Future F) (s ## ω) ∂T s) - (ρ s + (∑s'∈S. τ s s' * ι s s')) =
(∑s'∈S. τ s s' * enn2real (∫⇧+ω. reward (Future F) (s' ## ω) ∂T s'))"
proof -
let ?R = "reward (Future F)"
from s have "s ∈ Prob1 (Prob0 S ?F) S ?F"
unfolding Y_def N_def by auto
then have AE_until: "AE ω in T s. (HLD S suntil HLD (svalid F)) (s ## ω)"
using Prob1_iff[of S ?F] svalid_subset_S by auto
from s have "s ∉ ?F" by auto
let ?E = "λs'. ∫⇧+ ω. reward (Future F) (s' ## ω) ∂T s'"
have *: "(∑s'∈S. τ s s' * ?E s') = (∑s'∈S. ennreal (τ s s' * enn2real (?E s')))"
proof (rule sum.cong)
fix s' assume "s' ∈ S"
show "τ s s' * ?E s' = ennreal (τ s s' * enn2real (?E s'))"
proof cases
assume "τ s s' ≠ 0"
with ‹s ∈ S› ‹s' ∈ S› have "s' ∈ E s" by (simp add: set_pmf_iff)
from ‹s ∉ ?F› AE_until have "AE ω in T s. (HLD S suntil HLD ?F) (s ## ω)"
using svalid_subset_S ‹s ∈ S› by simp
with nn_integral_reward_finite[OF ‹s' ∈ S›, of F] ‹s ∈ S› ‹s' ∈ E s› ‹s ∉ ?F›
have "?E s' ≠ ∞"
by (simp add: AE_T_iff[of _ s] AE_measure_pmf_iff suntil_Stream
del: reward.simps)
then show ?thesis by (cases "?E s'") (auto simp: ennreal_mult)
qed simp
qed simp
have "AE ω in T s. ?R (s ## ω) = ρ s + ι s (shd ω) + ?R ω"
using ‹s ∉ svalid F› by (auto simp: ev_Stream )
then have "(∫⇧+ω. ?R (s ## ω) ∂T s) = (∫⇧+ω. (ρ s + ι s (shd ω)) + ?R ω ∂T s)"
by (rule nn_integral_cong_AE)
also have "… = (∫⇧+ω. ρ s + ι s (shd ω) ∂T s) +
(∫⇧+ω. ?R ω ∂T s)"
using ‹s ∈ S›
by (subst nn_integral_add)
(auto simp add: space_PiM PiE_iff simp del: reward.simps)
also have "… = ennreal (ρ s + (∑s'∈S. τ s s' * ι s s')) + (∫⇧+ω. ?R ω ∂T s)"
using ‹s ∈ S›
by (subst nn_integral_eq_sum)
(auto simp: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric] sum_nonneg)
finally show ?thesis
apply (simp del: reward.simps)
apply (subst nn_integral_eq_sum[OF ‹s ∈ S› reward_measurable])
apply (simp del: reward.simps ennreal_plus add: * ennreal_plus[symmetric] sum_nonneg)
done
qed
lemma uniqueness_of_ExpFuture:
fixes F
assumes N_def: "N ≡ Prob0 S (svalid F)" (is "_ ≡ Prob0 S ?F")
assumes Y_def: "Y ≡ Prob1 N S (svalid F)"
assumes const_def: "const ≡ λs. if s ∈ Y ∧ s ∉ svalid F then - ρ s - (∑s'∈S. τ s s' * ι s s') else 0"
assumes sol: "⋀s. s∈S ⟹ (∑s'∈S. LES (S - Y ∪ ?F) s s' * l s') = const s"
shows "∀s∈S. l s = enn2real (∫⇧+ω. reward (Future F) (s ## ω) ∂T s)"
(is "∀s∈S. l s = enn2real (∫⇧+ω. ?R (s ## ω) ∂T s)")
proof (rule unique)
show "S ⊆ S" "?F ⊆ S" using svalid_subset_S by auto
show "S - (Y - ?F) ⊆ S" "Prob0 S ?F ⊆ S - (Y - ?F)" "?F ⊆ S - (Y - ?F)"
using svalid_subset_S
by (auto simp add: Y_def N_def Prob1_iff)
(auto simp add: Prob0_iff dest!: T.AE_contr)
next
fix s assume "s ∈ S" "s ∉ S - (Y - ?F)"
then show "enn2real (∫⇧+ω. ?R (s ## ω) ∂T s) - (ρ s + (∑s'∈S. τ s s' * ι s s')) =
(∑s'∈S. τ s s' * enn2real (∫⇧+ω. ?R (s' ## ω) ∂T s'))"
by (rule existence_of_ExpFuture[OF N_def Y_def])
next
fix s assume "s ∈ S" "s ∉ S - (Y - ?F)"
then have "s ∈ Y" "s ∉ ?F" by auto
have "(∑s'∈S. (if s' = s then τ s s' - 1 else τ s s') * l s') =
(∑s'∈S. τ s s' * l s' - (if s' = s then 1 else 0) * l s')"
by (auto intro!: sum.cong simp: field_simps)
also have "… = (∑s'∈S. τ s s' * l s') - l s"
using ‹s ∈ S› by (simp add: sum_subtractf single_l)
finally have "l s = (∑s'∈S. τ s s' * l s') - (∑s'∈S. (if s' = s then τ s s' - 1 else τ s s') * l s')"
by (simp add: field_simps)
then show "l s - (ρ s + (∑s'∈S. τ s s' * ι s s')) = (∑s'∈S. τ s s' * l s')"
using sol[OF ‹s ∈ S›] ‹s ∈ Y› ‹s ∉ ?F› by (simp add: const_def LES_def)
next
fix s assume s: "s ∈ S - (Y - ?F)"
with sol[of s] have "l s = 0"
by (cases "s ∈ ?F") (simp_all add: const_def LES_def single_l)
also have "0 = enn2real (∫⇧+ω. reward (Future F) (s ## ω) ∂T s)"
proof cases
assume "s ∈ ?F" then show ?thesis
by (simp add: HLD_iff ev_Stream)
next
assume "s ∉ ?F"
with s have "s ∈ S - Y" by auto
with infinite_reward[of s F] show ?thesis
by (simp add: Y_def N_def del: reward.simps)
qed
finally show "l s = enn2real (∫⇧+ω. ?R (s ## ω) ∂T s)" .
qed
subsection ‹Soundness of @{const Sat}›
theorem Sat_sound:
"Sat F ≠ None ⟹ Sat F = Some (svalid F)"
proof (induct F rule: Sat.induct)
case (5 rel r F)
{ fix q assume "q ∈ S"
with svalid_subset_S have "sum (τ q) (svalid F) = 𝒫(ω in T q. HLD (svalid F) ω)"
by (subst prob_sum[OF ‹q∈S›]) (auto intro!: sum.mono_neutral_cong_left) }
with 5 show ?case
by (auto split: bind_split_asm)
next
case (6 rel r k F1 F2)
then show ?case
by (simp add: ProbU cong: conj_cong split: bind_split_asm)
next
case (7 rel r F1 F2)
moreover
define constants :: "'s ⇒ real" where "constants = (λs. if s ∈ (svalid F2) then 1 else 0)"
moreover define distr where "distr = LES (Prob0 (svalid F1) (svalid F2) ∪ svalid F2)"
ultimately obtain l where eq: "Sat F1 = Some (svalid F1)" "Sat F2 = Some (svalid F2)"
and l: "gauss_jordan' distr constants = Some l"
by atomize_elim (simp add: ProbUinfty_def split: bind_split_asm)
from l have P: "ProbUinfty (svalid F1) (svalid F2) = Some l"
unfolding ProbUinfty_def constants_def distr_def by simp
have "∀s∈S. l s = 𝒫(ω in T s. pvalid (U⇧∞ F1 F2) (s ## ω))"
proof (rule uniqueness_of_ProbU)
show "∀s∈S. (∑s'∈S. LES (Prob0 (svalid F1) (svalid F2) ∪ svalid F2) s s' * l s') =
(if s ∈ svalid F2 then 1 else 0)"
using gauss_jordan'_correct[OF l]
unfolding distr_def constants_def by simp
qed
then show ?case
by (auto simp add: eq P)
next
case (8 rel r k)
{ fix s assume "s ∈ S"
then have "ExpCumm s k = (∫⇧+ x. ennreal (∑i<k. ρ ((s ## x) !! i) + ι ((s ## x) !! i) (x !! i)) ∂T s)"
proof (induct k arbitrary: s)
case 0 then show ?case by simp
next
case (Suc k)
have "(∫⇧+ω. ennreal (∑i<Suc k. ρ ((s ## ω) !! i) + ι ((s ## ω) !! i) (ω !! i)) ∂T s)
= (∫⇧+ω. ennreal (ρ s + ι s (ω !! 0)) + ennreal (∑i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) ∂T s)"
by (auto intro!: nn_integral_cong
simp del: ennreal_plus
simp: ennreal_plus[symmetric] sum_nonneg sum.reindex lessThan_Suc_eq_insert_0 zero_notin_Suc_image)
also have "… = (∫⇧+ω. ρ s + ι s (ω !! 0) ∂T s) +
(∫⇧+ω. (∑i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) ∂T s)"
using ‹s ∈ S›
by (intro nn_integral_add AE_I2) (auto simp: sum_nonneg)
also have "… = (∑s'∈S. τ s s' * (ρ s + ι s s')) +
(∫⇧+ω. (∑i<k. ρ (ω !! i) + ι (ω !! i) (ω !! (Suc i))) ∂T s)"
using ‹s ∈ S› by (subst nn_integral_eq_sum)
(auto simp del: ennreal_plus simp: ennreal_plus[symmetric] ennreal_mult[symmetric] sum_nonneg)
also have "… = (∑s'∈S. τ s s' * (ρ s + ι s s')) +
(∑s'∈S. τ s s' * ExpCumm s' k)"
using ‹s ∈ S› by (subst nn_integral_eq_sum) (auto simp: Suc)
also have "… = ExpCumm s (Suc k)"
using ‹s ∈ S›
by (simp add: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric]
ennreal_plus[symmetric] sum_nonneg del: ennreal_plus)
finally show ?case by simp
qed }
then show ?case by auto
next
case (9 rel r k)
{ fix s assume "s ∈ S"
then have "ExpState s k = (∫⇧+ x. ennreal (ρ ((s ## x) !! k)) ∂T s)"
proof (induct k arbitrary: s)
case (Suc k) then show ?case by (simp add: nn_integral_eq_sum[of s])
qed simp }
then show ?case by auto
next
case (10 rel r F)
moreover
let ?F = "svalid F"
define N where "N ≡ Prob0 S ?F"
moreover define Y where "Y ≡ Prob1 N S ?F"
moreover define const where "const ≡ (λs. if s ∈ Y ∧ s ∉ ?F then - ρ s - (∑s'∈S. τ s s' * ι s s') else 0)"
ultimately obtain l
where l: "gauss_jordan' (LES (S - Y ∪ ?F)) const = Some l"
and F: "Sat F = Some ?F"
by (auto simp: ExpFuture_def Let_def split: bind_split_asm)
from l have EF: "ExpFuture ?F =
Some (λs. if s ∈ Y then ennreal (l s) else ∞)"
unfolding ExpFuture_def N_def Y_def const_def by auto
let ?R = "reward (Future F)"
have l_eq: "∀s∈S. l s = enn2real (∫⇧+ω. ?R (s ## ω) ∂T s)"
proof (rule uniqueness_of_ExpFuture[OF N_def Y_def const_def])
fix s assume "s ∈ S"
show "⋀s. s∈S ⟹ (∑s'∈S. LES (S - Y ∪ ?F) s s' * l s') = const s"
using gauss_jordan'_correct[OF l] by auto
qed
{ fix s assume [simp]: "s ∈ S" "s ∈ Y"
then have "s ∈ Prob1 (Prob0 S ?F) S ?F"
unfolding Y_def N_def by auto
then have "AE ω in T s. (HLD S suntil HLD ?F) (s ## ω)"
using svalid_subset_S by (auto simp add: Prob1_iff)
from nn_integral_reward_finite[OF ‹s ∈ S›] this
have "(∫⇧+ω. reward (Future F) (s ## ω) ∂T s) ≠ ∞"
by (simp add: )
with l_eq ‹s ∈ S› have "(∫⇧+ω. reward (Future F) (s ## ω) ∂T s) = ennreal (l s)"
by (auto simp: less_top) }
moreover
{ fix s assume "s ∈ S" "s ∉ Y"
with infinite_reward[of s F]
have "(∫⇧+ω. reward (Future F) (s ## ω) ∂T s) = ∞"
by (simp add: Y_def N_def) }
ultimately show ?case
apply (auto simp add: EF F simp del: reward.simps)
apply (case_tac "x ∈ Y")
apply auto
done
qed (auto split: bind_split_asm)
subsection ‹Completeness of @{const Sat}›
theorem Sat_complete:
"Sat F ≠ None"
proof (induct F rule: Sat.induct)
case (7 r rel Φ Ψ)
then have F: "Sat Φ = Some (svalid Φ)" "Sat Ψ = Some (svalid Ψ)"
by (auto intro!: Sat_sound)
define constants :: "'s ⇒ real" where "constants = (λs. if s ∈ svalid Ψ then 1 else 0)"
define distr where "distr = LES (Prob0 (svalid Φ) (svalid Ψ) ∪ svalid Ψ)"
have "∃l. gauss_jordan' distr constants = Some l"
proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ProbU])
show "∀s∈S. (∑s'∈S. distr s s' * 𝒫(ω in T s'. pvalid (U⇧∞ Φ Ψ) (s' ## ω))) = constants s"
apply (simp add: distr_def constants_def LES_def del: pvalid.simps space_T)
proof safe
fix s assume "s ∈ svalid Ψ" "s ∈ S"
then show "(∑s'∈S. (if s' = s then 1 else 0) * 𝒫(ω in T s'. pvalid (U⇧∞ Φ Ψ) (s' ## ω))) = 1"
by (simp add: single_l suntil_Stream)
next
fix s assume s: "s ∉ svalid Ψ" "s ∈ S"
let ?x = "λs'. 𝒫(ω in T s'. pvalid (U⇧∞ Φ Ψ) (s' ## ω))"
show "(∑s'∈S. (if s ∈ Prob0 (svalid Φ) (svalid Ψ) then if s' = s then 1 else 0 else if s' = s then τ s s' - 1 else τ s s') * ?x s') = 0"
proof cases
assume "s ∈ Prob0 (svalid Φ) (svalid Ψ)"
with s show ?thesis
by (simp add: single_l Prob0_iff svalid_subset_S T.prob_eq_0_AE del: space_T)
next
assume s_not_0: "s ∉ Prob0 (svalid Φ) (svalid Ψ)"
with s have *:"⋀s' ω. s' ∈ S ⟹ pvalid (U⇧∞ Φ Ψ) (s ## s' ## ω) = pvalid (U⇧∞ Φ Ψ) (s' ## ω)"
by (auto simp: suntil_Stream Prob0_iff svalid_subset_S)
have "(∑s'∈S. (if s' = s then τ s s' - 1 else τ s s') * ?x s') =
(∑s'∈S. τ s s' * ?x s' - (if s' = s then 1 else 0) * ?x s')"
by (auto intro!: sum.cong simp: field_simps)
also have "… = (∑s'∈S. τ s s' * ?x s') - ?x s"
using s by (simp add: single_l sum_subtractf)
finally show ?thesis
using * prob_sum[OF ‹s ∈ S›] s_not_0 by (simp del: pvalid.simps)
qed
qed
qed (simp add: distr_def constants_def)
then have P: "∃l. ProbUinfty (svalid Φ) (svalid Ψ) = Some l"
unfolding ProbUinfty_def constants_def distr_def by simp
with F show ?case
by auto
next
case (10 rel r Φ)
then have F: "Sat Φ = Some (svalid Φ)"
by (auto intro!: Sat_sound)
let ?F = "svalid Φ"
define N where "N ≡ Prob0 S ?F"
define Y where "Y ≡ Prob1 N S ?F"
define const where "const ≡ (λs. if s ∈ Y ∧ s ∉ ?F then - ρ s - (∑s'∈S. τ s s' * ι s s') else 0)"
let ?E = "λs'. ∫⇧+ ω. reward (Future Φ) (s' ## ω) ∂T s'"
have "∃l. gauss_jordan' (LES (S - Y ∪ ?F)) const = Some l"
proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ExpFuture[OF N_def Y_def const_def]])
show "∀s∈S. (∑s'∈S. LES (S - Y ∪ svalid Φ) s s' * enn2real (?E s')) = const s"
proof
fix s assume "s ∈ S"
show "(∑s'∈S. LES (S - Y ∪ svalid Φ) s s' * enn2real (?E s')) = const s"
proof cases
assume s: "s ∈ S - (Y - svalid Φ)"
show ?thesis
proof cases
assume "s ∈ Y"
with ‹s ∈ S› s ‹s ∈ Y› show ?thesis
by (simp add: LES_def const_def single_l ev_Stream)
next
assume "s ∉ Y"
with infinite_reward[of s Φ] Y_def N_def s ‹s ∈ S›
show ?thesis by (simp add: const_def LES_def single_l del: reward.simps)
qed
next
assume s: "s ∉ S - (Y - svalid Φ)"
have "(∑s'∈S. (if s' = s then τ s s' - 1 else τ s s') * enn2real (?E s')) =
(∑s'∈S. τ s s' * enn2real (?E s') - (if s' = s then 1 else 0) * enn2real (?E s'))"
by (auto intro!: sum.cong simp: field_simps)
also have "… = (∑s'∈S. τ s s' * enn2real (?E s')) - enn2real (?E s)"
using ‹s ∈ S› by (simp add: sum_subtractf single_l)
finally show ?thesis
using s ‹s ∈ S› existence_of_ExpFuture[OF N_def Y_def ‹s ∈ S› s]
by (simp add: LES_def const_def del: reward.simps)
qed
qed
qed simp
then have P: "∃l. ExpFuture (svalid Φ) = Some l"
unfolding ExpFuture_def const_def N_def Y_def by auto
with F show ?case
by auto
qed (force split: bind_split)+
subsection ‹Completeness and Soundness @{const Sat}›
corollary Sat: "Sat Φ = Some (svalid Φ)"
using Sat_sound Sat_complete by auto
end
end
Theory PGCL
section ‹Probabilistic Guarded Command Language (pGCL)›
theory PGCL
imports "../Markov_Decision_Process"
begin
subsection ‹Syntax›
datatype 's pgcl =
Skip
| Abort
| Assign "'s ⇒ 's"
| Seq "'s pgcl" "'s pgcl"
| Par "'s pgcl" "'s pgcl"
| If "'s ⇒ bool" "'s pgcl" "'s pgcl"
| Prob "bool pmf" "'s pgcl" "'s pgcl"
| While "'s ⇒ bool" "'s pgcl"
subsection ‹Denotational Semantics›
primrec wp :: "'s pgcl ⇒ ('s ⇒ ennreal) ⇒ ('s ⇒ ennreal)" where
"wp Skip f = f"
| "wp Abort f = (λ_. 0)"
| "wp (Assign u) f = f ∘ u"
| "wp (Seq c⇩1 c⇩2) f = wp c⇩1 (wp c⇩2 f)"
| "wp (If b c⇩1 c⇩2) f = (λs. if b s then wp c⇩1 f s else wp c⇩2 f s)"
| "wp (Par c⇩1 c⇩2) f = wp c⇩1 f ⊓ wp c⇩2 f"
| "wp (Prob p c⇩1 c⇩2) f = (λs. pmf p True * wp c⇩1 f s + pmf p False * wp c⇩2 f s)"
| "wp (While b c) f = lfp (λX s. if b s then wp c X s else f s)"
lemma wp_mono: "mono (wp c)"
by (induction c)
(auto simp: mono_def le_fun_def intro: order_trans le_infI1 le_infI2
intro!: add_mono mult_left_mono lfp_mono[THEN le_funD])
abbreviation det :: "'s pgcl ⇒ 's ⇒ ('s pgcl × 's) pmf set" ("≪ _, _ ≫") where
"det c s ≡ {return_pmf (c, s)}"
subsection ‹Operational Semantics›
fun step :: "('s pgcl × 's) ⇒ ('s pgcl × 's) pmf set" where
"step (Skip, s) = ≪Skip, s≫"
| "step (Abort, s) = ≪Abort, s≫"
| "step (Assign u, s) = ≪Skip, u s≫"
| "step (Seq c⇩1 c⇩2, s) = (map_pmf (λ(p1', s'). (if p1' = Skip then c⇩2 else Seq p1' c⇩2, s'))) ` step (c⇩1, s)"
| "step (If b c⇩1 c⇩2, s) = (if b s then ≪c⇩1, s≫ else ≪c⇩2, s≫)"
| "step (Par c⇩1 c⇩2, s) = ≪c⇩1, s≫ ∪ ≪c⇩2, s≫"
| "step (Prob p c⇩1 c⇩2, s) = {map_pmf (λb. if b then (c⇩1, s) else (c⇩2, s)) p}"
| "step (While b c, s) = (if b s then ≪Seq c (While b c), s≫ else ≪Skip, s≫)"
lemma step_finite: "finite (step x)"
by (induction x rule: step.induct) simp_all
lemma step_non_empty: "step x ≠ {}"
by (induction x rule: step.induct) simp_all
interpretation step: Markov_Decision_Process step
proof qed (rule step_non_empty)
definition rF :: "('s ⇒ ennreal) ⇒ (('s pgcl × 's) stream ⇒ ennreal) ⇒ ('s pgcl × 's) stream ⇒ ennreal" where
"rF f F ω = (if fst (shd ω) = Skip then f (snd (shd ω)) else F (stl ω))"
abbreviation r :: "('s ⇒ ennreal) ⇒ ('s pgcl × 's) stream ⇒ ennreal" where
"r f ≡ lfp (rF f)"
lemma continuous_rF: "sup_continuous (rF f)"
unfolding rF_def[abs_def]
by (auto simp: sup_continuous_def fun_eq_iff SUP_sup_distrib [symmetric] image_comp
split: prod.splits pgcl.splits)
lemma mono_rF: "mono (rF f)"
using continuous_rF by (rule sup_continuous_mono)
lemma r_unfold: "r f ω = (if fst (shd ω) = Skip then f (snd (shd ω)) else r f (stl ω))"
by (subst lfp_unfold[OF mono_rF]) (simp add: rF_def)
lemma mono_r: "F ≤ G ⟹ r F ω ≤ r G ω"
by (rule le_funD[of _ _ ω], rule lfp_mono)
(auto intro!: lfp_mono simp: rF_def le_fun_def max.coboundedI2)
lemma measurable_rF:
assumes F[measurable]: "F ∈ borel_measurable step.St"
shows "rF f F ∈ borel_measurable step.St"
unfolding rF_def[abs_def]
apply measurable
apply (rule measurable_compose[OF measurable_shd])
apply measurable []
apply (rule measurable_compose[OF measurable_stl])
apply measurable []
apply (rule predE)
apply (rule measurable_compose[OF measurable_shd])
apply measurable
done
lemma measurable_r[measurable]: "r f ∈ borel_measurable step.St"
using continuous_rF measurable_rF by (rule borel_measurable_lfp)
lemma mono_r': "mono (λF s. ⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else F t) ∂measure_pmf D)"
by (auto intro!: monoI le_funI INF_mono[OF bexI] nn_integral_mono simp: le_fun_def)
lemma E_inf_r:
"step.E_inf s (r f) =
lfp (λF s. ⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else F t) ∂measure_pmf D) s"
proof -
have "step.E_inf s (r f) =
lfp (λF s. ⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else F t) ∂measure_pmf D) s"
unfolding rF_def[abs_def]
proof (rule step.E_inf_lfp[THEN fun_cong])
let ?F = "λt x. (if fst t = Skip then f (snd t) else x)"
show "(λ(s, x). ?F s x) ∈ borel_measurable (count_space UNIV ⨂⇩M borel)"
apply (simp add: measurable_split_conv split_beta')
apply (intro borel_measurable_max borel_measurable_const measurable_If predE
measurable_compose[OF measurable_snd] measurable_compose[OF measurable_fst])
apply measurable
done
show "⋀s. sup_continuous (?F s)"
by (auto simp: sup_continuous_def SUP_sup_distrib[symmetric] split: prod.split pgcl.split)
show "⋀F cfg. (∫⇧+ω. ?F (state cfg) (F ω) ∂step.T cfg) =
?F (state cfg) (nn_integral (step.T cfg) F)"
by (auto simp: split: pgcl.split prod.split)
qed (rule step_finite)
then show ?thesis
by simp
qed
lemma E_inf_r_unfold:
"step.E_inf s (r f) = (⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else step.E_inf t (r f)) ∂measure_pmf D)"
unfolding E_inf_r by (simp add: lfp_unfold[OF mono_r'])
lemma E_inf_r_induct[consumes 1, case_names step]:
assumes "P s y"
assumes *: "⋀F s y. P s y ⟹
(⋀s y. P s y ⟹ F s ≤ y) ⟹ (⋀s. F s ≤ step.E_inf s (r f)) ⟹
(⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else F t) ∂measure_pmf D) ≤ y"
shows "step.E_inf s (r f) ≤ y"
using ‹P s y›
unfolding E_inf_r
proof (induction arbitrary: s y rule: lfp_ordinal_induct[OF mono_r'[where f=f]])
case (1 F) with *[of s y F] show ?case
unfolding le_fun_def E_inf_r[where f=f, symmetric] by simp
qed (auto intro: SUP_least)
lemma E_inf_Skip: "step.E_inf (Skip, s) (r f) = f s"
by (subst E_inf_r_unfold) simp
lemma E_inf_Seq:
assumes [simp]: "⋀x. 0 ≤ f x"
shows "step.E_inf (Seq a b, s) (r f) = step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f)))"
proof (rule antisym)
show "step.E_inf (Seq a b, s) (r f) ≤ step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f)))"
proof (coinduction arbitrary: a s rule: E_inf_r_induct)
case step then show ?case
by (rewrite in "_ ≤ ⌑" E_inf_r_unfold)
(force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
simp: E_inf_Skip image_comp)
qed
show "step.E_inf (a, s) (r (λs. step.E_inf (b, s) (r f))) ≤ step.E_inf (Seq a b, s) (r f)"
proof (coinduction arbitrary: a s rule: E_inf_r_induct)
case step then show ?case
by (rewrite in "_ ≤ ⌑" E_inf_r_unfold)
(force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
simp: E_inf_Skip image_comp)
qed
qed
lemma E_inf_While:
"step.E_inf (While g c, s) (r f) =
lfp (λF s. if g s then step.E_inf (c, s) (r F) else f s) s"
proof (rule antisym)
have E_inf_While_step: "step.E_inf (While g c, s) (r f) =
(if g s then step.E_inf (c, s) (r (λs. step.E_inf (While g c, s) (r f))) else f s)" for f s
by (rewrite E_inf_r_unfold) (simp add: min_absorb1 E_inf_Seq)
have "mono (λF s. if g s then step.E_inf (c, s) (r F) else f s)" (is "mono ?F")
by (auto intro!: mono_r step.E_inf_mono simp: mono_def le_fun_def max.coboundedI2)
then show "lfp ?F s ≤ step.E_inf (While g c, s) (r f)"
proof (induction arbitrary: s rule: lfp_ordinal_induct[consumes 1])
case mono then show ?case
by (rewrite E_inf_While_step) (auto intro!: step.E_inf_mono mono_r le_funI)
qed (auto intro: SUP_least)
define w where "w F s = (⨅D∈step s. ∫⇧+ t. (if fst t = Skip then if g (snd t) then F (c, snd t) else f (snd t) else F t) ∂measure_pmf D)"
for F s
have "mono w"
by (auto simp: w_def mono_def le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono) []
define d where "d = c"
define t where "t = Seq d (While g c)"
then have "(t = While g c ∧ d = c ∧ g s) ∨ t = Seq d (While g c)"
by auto
then have "step.E_inf (t, s) (r f) ≤ lfp w (d, s)"
proof (coinduction arbitrary: t d s rule: E_inf_r_induct)
case (step F t d s)
from step(1)
show ?case
proof (elim conjE disjE)
{ fix s have "¬ g s ⟹ F (While g c, s) ≤ f s"
using step(3)[of "(While g c, s)"] by (simp add: E_inf_While_step) }
note [simp] = this
assume "t = Seq d (While g c)" then show ?thesis
by (rewrite lfp_unfold[OF ‹mono w›])
(auto simp: max.absorb2 w_def intro!: INF_mono[OF bexI] nn_integral_mono step)
qed (auto intro!: step)
qed
also have "lfp w = lfp (λF s. step.E_inf s (r (λs. if g s then F (c, s) else f s)))"
unfolding E_inf_r w_def
by (rule lfp_lfp[symmetric]) (auto simp: le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono)
finally have "step.E_inf (While g c, s) (r f) ≤ (if g s then … (c, s) else f s)"
unfolding t_def d_def by (rewrite E_inf_r_unfold) simp
also have "… = lfp ?F s"
by (rewrite lfp_rolling[symmetric, of "λF s. if g s then F (c, s) else f s" "λF s. step.E_inf s (r F)"])
(auto simp: mono_def le_fun_def sup_apply[abs_def] if_distrib[of "max 0"] max.coboundedI2 max.absorb2
intro!: step.E_inf_mono mono_r cong del: if_weak_cong)
finally show "step.E_inf (While g c, s) (r f) ≤ …"
.
qed
subsection ‹Equate Both Semantics›
lemma E_inf_r_eq_wp: "step.E_inf (c, s) (r f) = wp c f s"
proof (induction c arbitrary: f s)
case Skip then show ?case
by (simp add: E_inf_Skip)
next
case Abort then show ?case
proof (intro antisym)
have "lfp (λF s. ⨅D∈step s. ∫⇧+ t. (if fst t = Skip then f (snd t) else F t) ∂measure_pmf D) ≤
(λs. if ∃t. s = (Abort, t) then 0 else ⊤)"
by (intro lfp_lowerbound) (auto simp: le_fun_def)
then show "step.E_inf (Abort, s) (r f) ≤ wp Abort f s"
by (auto simp: E_inf_r le_fun_def split: if_split_asm)
qed simp
next
case Assign then show ?case
by (rewrite E_inf_r_unfold) (simp add: min_absorb1)
next
case (If b c1 c2) then show ?case
by (rewrite E_inf_r_unfold) auto
next
case (Prob p c1 c2) then show ?case
apply (rewrite E_inf_r_unfold)
apply auto
apply (rewrite nn_integral_measure_pmf_support[of "UNIV::bool set"])
apply (auto simp: UNIV_bool ac_simps)
done
next
case (Par c1 c2) then show ?case
by (rewrite E_inf_r_unfold) (auto intro: inf.commute)
next
case (Seq c1 c2) then show ?case
by (simp add: E_inf_Seq)
next
case (While g c) then show ?case
apply (simp add: E_inf_While)
apply (rewrite While)
apply auto
done
qed
end
Theory Crowds_Protocol
section ‹Formalization of the Crowds-Protocol›
theory Crowds_Protocol
imports "../Discrete_Time_Markov_Chain"
begin
lemma cond_prob_nonneg[simp]: "0 ≤ cond_prob M A B"
by (auto simp: cond_prob_def)
lemma (in MC_syntax) emeasure_suntil_geometric:
assumes [measurable]: "Measurable.pred S P"
assumes "s ∈ X" and *[simp]: "0 ≤ p" "0 ≤ r"
assumes r: "⋀s. s ∈ X ⟹ emeasure (T s) {ω∈space (T s). P ω} = ennreal r"
assumes p: "⋀s. s ∈ X ⟹ emeasure (K s) X = ennreal p" "p < 1"
assumes "⋀t. AE ω in T t. ¬ (P ⊓ (HLD X ⊓ nxt (HLD X suntil P))) ω"
shows "emeasure (T s) {ω∈space (T s). (HLD X suntil P) ω} = r / (1 - p)"
proof (subst emeasure_suntil_disj)
let ?F = "λF s. emeasure (T s) {ω ∈ space (T s). P ω} + ∫⇧+ t. F t * indicator X t ∂K s"
let ?f = "λx. ennreal r + ennreal p * x"
have "mono ?F" "mono ?f"
by (auto intro!: monoI max.mono add_mono nn_integral_mono mult_left_mono mult_right_mono simp: le_fun_def)
have 1: "lfp ?f ≤ lfp ?F s"
using ‹s ∈ X›
proof (induction arbitrary: s rule: lfp_ordinal_induct[OF ‹mono ?f›])
case step: (1 x)
then have "?f x ≤ ?F (λ_. x) s"
by (auto simp: p r[simplified] nn_integral_cmult mult.commute[of _ x]
intro!: add_mono mult_right_mono)
also have "?F (λ_. x) ≤ ?F (lfp ?F)"
using step
by (intro le_funI add_mono order_refl nn_integral_mono) (auto simp: split: split_indicator)
finally show ?case
by (subst lfp_unfold[OF ‹mono ?F›]) (auto simp: le_fun_def)
qed (auto intro!: Sup_least)
also have 2: "lfp ?F s ≤ r / (1 - p)"
using ‹s ∈ X›
proof (induction arbitrary: s rule: lfp_ordinal_induct[OF ‹mono ?F›])
case (1 S)
with r have "?F S s ≤ ennreal r + (∫⇧+x. ennreal (r / (1 - p)) * indicator X x ∂K s)"
by (intro add_mono nn_integral_mono) (auto split: split_indicator)
also have "… ≤ ennreal r + ennreal (r * p / (1 - p))"
using ‹s ∈ X› by (simp add: nn_integral_cmult_indicator p ennreal_mult''[symmetric])
also have "… = ennreal (r / (1 - p))"
using ‹p < 1› by (simp add: field_simps ennreal_plus[symmetric] del: ennreal_plus)
finally show ?case .
qed (auto intro!: SUP_least)
finally obtain x where x: "lfp ?f = ennreal x" and [simp]: "0 ≤ x"
by (cases "lfp ?f") (auto simp: top_unique)
from ‹p < 1› have "⋀x. x = r + p * x ⟹ x = r / (1 - p)"
by (auto simp: field_simps)
with lfp_unfold[OF ‹mono ?f›] ‹p < 1› have "lfp ?f = r / (1 - p)"
unfolding x by (auto simp add: ennreal_plus[symmetric] ennreal_mult[symmetric] simp del: ennreal_plus)
with 1 2 show "lfp ?F s = ennreal (r / (1 - p))"
by auto
qed fact+
subsection ‹Definition of the Crowds-Protocol›
datatype 'a state = Start | Init 'a | Mix 'a | End
lemma inj_Mix[simp]: "inj_on Mix A"
by (auto intro: inj_onI)
lemma inj_Init[simp]: "inj_on Init A"
by (auto intro: inj_onI)
lemma distinct_state_image[simp]:
"Start ∉ Mix ` A" "Init j ∉ Mix ` A" "End ∉ Mix ` A" "Mix j ∈ Mix ` A ⟷ j ∈ A"
"Start ∉ Init ` A" "Mix j ∉ Init ` A" "End ∉ Init ` A" "Init j ∈ Init ` A ⟷ j ∈ A"
by auto
lemma Init_cut_Mix[simp]:
"Init ` H ∩ Mix ` J = {}"
by auto
abbreviation "Jondo B ≡ Init`B ∪ Mix`B"
locale Crowds_Protocol =
fixes J :: "'a set" and C :: "'a set" and p_f :: real and p_i :: "'a ⇒ real"
assumes J_not_empty: "J ≠ {}" and finite_J[simp]: "finite J"
assumes C_smaller: "C ⊂ J" and C_non_empty: "C ≠ {}"
assumes p_f: "0 < p_f" "p_f < 1"
assumes p_i_nonneg[simp]: "⋀j. j ∈ J ⟹ 0 ≤ p_i j"
assumes p_i_distr: "(∑j∈J. p_i j) = 1"
assumes p_i_C: "⋀j. j ∈ C ⟹ p_i j = 0"
begin
abbreviation H :: "'a set" where
"H ≡ J - C"
definition "p_j = 1 / card J"
lemma p_f_nonneg[simp]: "0 ≤ p_f" "p_f ≤ 1"
using p_f by simp_all
lemma p_j_nonneg[simp]: "0 ≤ p_j"
by (simp add: p_j_def)
definition "p_H = card H / card J"
lemma p_H_nonneg[simp]: "0 ≤ p_H" "p_H ≤ 1"
by (auto simp: p_H_def divide_le_eq_1 card_gt_0_iff intro!: card_mono )
definition next_prob :: "'a state ⇒ 'a state ⇒ real" where
"next_prob s t = (case (s, t) of (Start, Init j) ⇒ if j ∈ H then p_i j else 0
| (Init j, Mix j') ⇒ if j' ∈ J then p_j else 0
| (Mix j, Mix j') ⇒ if j' ∈ J then p_f * p_j else 0
| (Mix j, End) ⇒ 1 - p_f
| (End, End) ⇒ 1
| _ ⇒ 0)"
definition "N s = embed_pmf (next_prob s)"
interpretation MC_syntax N .
abbreviation "𝔓 ≡ T Start"
abbreviation "E s ≡ set_pmf (N s)"
lemma finite_C[simp]: "finite C"
using C_smaller finite_J by (blast intro: finite_subset)
lemma sum_p_i_C[simp]: "sum p_i C = 0"
by (auto intro: sum.neutral p_i_C)
lemma sum_p_i_H[simp]: "sum p_i H = 1"
using C_smaller by (simp add: sum_diff p_i_distr)
lemma possible_jondo:
obtains j where "j ∈ J" "j ∉ C" "p_i j ≠ 0"
proof (atomize_elim, rule ccontr)
assume "¬ (∃j. j ∈ J ∧ j ∉ C ∧ p_i j ≠ 0)"
with p_i_C have "∀j∈J. p_i j = 0"
by auto
with p_i_distr show False
by simp
qed
lemma C_le_J[simp]: "card C < card J"
using C_smaller
by (intro psubset_card_mono) auto
lemma p_H: "0 < p_H" "p_H < 1"
using J_not_empty C_smaller C_non_empty
by (simp_all add: p_H_def card_Diff_subset card_mono field_simps zero_less_divide_iff card_gt_0_iff)
lemma p_H_p_f_pos: "0 < p_H * p_f"
using p_f p_H by (simp add: zero_less_mult_iff)
lemma p_H_p_f_less_1: "p_H * p_f < 1"
proof -
have "p_H * p_f < 1 * 1"
using p_H p_f by (intro mult_strict_mono) auto
then show "p_H * p_f < 1" by simp
qed
lemma p_j_pos: "0 < p_j"
unfolding p_j_def using J_not_empty by auto
lemma H_compl: "1 - p_H = real (card C) / real (card J)"
using C_non_empty J_not_empty C_smaller
by (simp add: p_H_def card_Diff_subset card_mono of_nat_diff divide_eq_eq field_simps)
lemma H_compl2: "1 - p_H = card C * p_j"
unfolding H_compl p_j_def by simp
lemma H_eq2: "card H * p_j = p_H"
unfolding p_j_def p_H_def by simp
lemma pmf_next_pmf[simp]: "pmf (N s) t = next_prob s t"
unfolding N_def
proof (rule pmf_embed_pmf)
show "⋀x. 0 ≤ next_prob s x"
using p_j_pos p_f by (auto simp: next_prob_def intro: p_i_nonneg split: state.split)
show "(∫⇧+ x. ennreal (next_prob s x) ∂count_space UNIV) = 1"
using p_f J_not_empty
by (subst nn_integral_count_space'[where A="Init`H ∪ Mix`J ∪ {End}"])
(auto simp: next_prob_def sum.reindex sum.union_disjoint p_i_distr p_j_def
split: state.split)
qed
lemma next_prob_Start[simp]: "next_prob Start (Init j) = (if j ∈ H then p_i j else 0)"
by (auto simp: next_prob_def)
lemma next_prob_to_Init[simp]: "j ∈ H ⟹ next_prob s (Init j) =
(case s of Start ⇒ p_i j | _ ⇒ 0)"
by (cases s) (auto simp: next_prob_def)
lemma next_prob_to_Mix[simp]: "j ∈ J ⟹ next_prob s (Mix j) =
(case s of Init j ⇒ p_j | Mix j ⇒ p_f * p_j | _ ⇒ 0)"
by (cases s) (auto simp: next_prob_def)
lemma next_prob_to_End[simp]: "next_prob s End =
(case s of Mix j ⇒ 1 - p_f | End ⇒ 1 | _ ⇒ 0)"
by (cases s) (auto simp: next_prob_def)
lemma next_prob_from_End[simp]: "next_prob End s = 0 ⟷ s ≠ End"
by (cases s) (auto simp: next_prob_def)
lemma next_prob_Mix_MixI: "∃j. s = Mix j ⟹ ∃j∈J. s' = Mix j ⟹ next_prob s s' = p_f * p_j"
by (cases s) auto
lemma E_Start: "E Start = {Init j | j. j ∈ H ∧ p_i j ≠ 0 }"
using p_i_C by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)
lemma E_Init: "E (Init j) = {Mix j | j. j ∈ J }"
using p_j_pos C_smaller by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)
lemma E_Mix: "E (Mix j) = {Mix j | j. j ∈ J } ∪ {End}"
using p_j_pos p_f by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)
lemma E_End: "E End = {End}"
by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)
lemma enabled_End:
"enabled End ω ⟷ ω = sconst End"
proof safe
assume "enabled End ω" then show "ω = sconst End"
proof (coinduction arbitrary: ω)
case Eq_stream then show ?case
by (auto simp: enabled.simps[of _ ω] E_End)
qed
next
show "enabled End (sconst End)"
by coinduction (simp add: E_End)
qed
lemma AE_End: "(AE ω in T End. P ω) ⟷ P (sconst End)"
proof -
have "(AE ω in T End. P ω) ⟷ (AE ω in T End. P ω ∧ ω = sconst End)"
using AE_T_enabled[of End] by (simp add: enabled_End)
also have "… = (AE ω in T End. P (sconst End) ∧ ω = sconst End)"
by (simp add: enabled_End del: AE_conj_iff cong: rev_conj_cong)
also have "… = (AE ω in T End. P (sconst End))"
using AE_T_enabled[of End] by (simp add: enabled_End)
finally show ?thesis
by simp
qed
lemma emeasure_Init_eq_Mix:
assumes [measurable]: "Measurable.pred S P"
assumes AE_End: "AE x in T End. ¬ P (End ## x)"
shows "emeasure (T (Init j)) {x∈space (T (Init j)). P x} =
emeasure (T (Mix j)) {x∈space (T (Mix j)). P x} / p_f"
proof -
have *: "{Mix j | j. j ∈ J } = Mix ` J"
by auto
show ?thesis
using emeasure_eq_0_AE[OF AE_End] p_f
apply (subst (1 2) emeasure_Collect_T)
apply simp
apply (subst (1 2) nn_integral_measure_pmf_finite)
apply (auto simp: E_Mix E_Init * sum.reindex sum_distrib_right[symmetric] divide_ennreal
ennreal_times_divide[symmetric])
done
qed
text ‹
What is the probability that the server sees a specific jondo (including the initiator) as sender.
›
definition visit :: "'a set ⇒ 'a set ⇒ 'a state stream ⇒ bool" where
"visit I L = Init`(I ∩ H) ⋅ (HLD (Mix`J) suntil (Mix`(L ∩ J) ⋅ HLD {End}))"
lemma visit_unique1:
"visit I1 L1 ω ⟹ visit I2 L2 ω ⟹ I1 ∩ I2 ≠ {}"
by (auto simp: visit_def HLD_iff)
lemma visit_unique2:
assumes "visit I1 L1 ω" "visit I2 L2 ω"
shows "L1 ∩ L2 ≠ {}"
proof -
let ?U = "λL ω. (HLD (Mix`J) suntil ((Mix`(L∩J)) ⋅ HLD {End})) ω"
have "?U L1 (stl ω)" "?U L2 (stl ω)"
using assms by (auto simp: visit_def)
then show "L1 ∩ L2 ≠ {}"
proof (induction "stl ω" arbitrary: ω rule: suntil_induct_strong)
case base then show ?case
by (auto simp add: suntil.simps[of _ _ "stl (stl ω)"] suntil.simps[of _ _ "stl ω"] HLD_iff)
next
case step
show ?case
proof cases
assume "((Mix`(L2∩J)) ⋅ HLD {End}) (stl ω)"
with step.hyps show ?thesis
by (auto simp: inj_Mix HLD_iff elim: suntil.cases)
next
assume "¬ ((Mix`(L2∩J)) ⋅ HLD {End}) (stl ω)"
with step.prems have "?U L2 (stl (stl ω))"
by (auto elim: suntil.cases)
then show ?thesis
by (rule step.hyps(4)[OF refl])
qed
qed
qed
lemma visit_imp_in_H: "visit {i} J ω ⟹ i ∈ H"
by (auto simp: visit_def HLD_iff)
lemma emeasure_visit:
assumes I: "I ⊆ H" and L: "L ⊆ J"
shows "emeasure 𝔓 {ω∈space 𝔓. visit I L ω} = (∑i∈I. p_i i) * (card L * p_j)"
proof -
let ?J = "HLD (Mix`J)" and ?E = "(Mix`L) ⋅ HLD {End}"
let ?φ = "?J aand not ?E"
let ?P = "λx P. emeasure (T x) {ω∈space (T x). P ω}"
have [intro]: "finite L"
using finite_J ‹L ⊆ J› by (blast intro: finite_subset)
have [simp, intro]: "finite I"
using finite_J ‹I ⊆ H› by (blast intro: finite_subset)
{ fix j assume j: "j ∈ H"
have "?P (Mix j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f)"
proof (rule emeasure_suntil_geometric)
fix s assume s: "s ∈ Mix ` J"
then have "?P s ?E = (∫⇧+x. ennreal (1 - p_f) * indicator (Mix`L) x ∂N s)"
by (auto simp add: emeasure_HLD_nxt emeasure_HLD AE_measure_pmf_iff emeasure_pmf_single
split: state.split split_indicator simp del: space_T nxt.simps
intro!: nn_integral_cong_AE)
also have "… = ennreal (1 - p_f) * emeasure (N s) (Mix`L)"
using p_f by (intro nn_integral_cmult_indicator) auto
also have "… = ennreal ((1 - p_f) * card L * p_j * p_f)"
using s assms
by (subst emeasure_measure_pmf_finite)
(auto simp: sum.reindex subset_eq ennreal_mult mult_ac)
finally show "?P s ?E = p_f * p_j * (1 - p_f) * card L"
by simp
next
show "⋀t. AE ω in T t. ¬ (?E ⊓ (?J ⊓ nxt (?J suntil ?E))) ω"
by (intro AE_I2) (auto simp: HLD_iff elim: suntil.cases)
qed (insert p_f j, auto simp: emeasure_measure_pmf_finite sum.reindex p_j_def)
then have "?P (Init j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f) / p_f"
by (subst emeasure_Init_eq_Mix) (simp_all add: suntil.simps[of _ _ "x ## s" for x s] divide_ennreal p_f)
then have "?P (Init j) (?J suntil ?E) = p_j * card L"
using p_f by simp }
note J_suntil_E = this
have "?P Start (visit I L) = (∫⇧+x. ?P x (?J suntil ?E) * indicator (Init`I) x ∂N Start)"
unfolding visit_def using I L by (subst emeasure_HLD_nxt) (auto simp: Int_absorb2)
also have "… = (∫⇧+x. ennreal (p_j * card L) * indicator (Init`I) x ∂N Start)"
using I J_suntil_E
by (intro nn_integral_cong ennreal_mult_right_cong)
(auto split: split_indicator_asm)
also have "… = ennreal ((∑i∈I. p_i i) * card L * p_j)"
using p_j_pos assms
by (subst nn_integral_cmult_indicator)
(auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq ennreal_mult[symmetric] sum_nonneg)
finally show ?thesis by (simp add: ac_simps)
qed
lemma measurable_visit[measurable]: "Measurable.pred S (visit I L)"
by (simp add: visit_def)
lemma AE_visit: "AE ω in 𝔓. visit H J ω"
proof (rule T.AE_I_eq_1)
show "emeasure 𝔓 {ω∈space 𝔓. visit H J ω} = 1"
using J_not_empty by (subst emeasure_visit ) (simp_all add: p_j_def)
qed simp
subsection ‹Server gets no information›
lemma server_view1: "j ∈ J ⟹ 𝒫(ω in 𝔓. visit H {j} ω) = p_j"
unfolding measure_def by (subst emeasure_visit) simp_all
lemma server_view_indep:
"L ⊆ J ⟹ I ⊆ H ⟹ 𝒫(ω in 𝔓. visit I L ω) = 𝒫(ω in 𝔓. visit H L ω) * 𝒫(ω in 𝔓. visit I J ω)"
unfolding measure_def
by (subst (1 2 3) emeasure_visit) (auto simp: p_j_def sum_nonneg subset_eq)
lemma server_view: "𝒫(ω in 𝔓. ∃j∈H. visit {j} {j} ω) = p_j"
using finite_J
proof (subst T.prob_sum[where I="H" and P="λj. visit {j} {j}"])
show "(∑j∈H. 𝒫(ω in 𝔓. visit {j} {j} ω)) = p_j"
by (auto simp: measure_def emeasure_visit sum_distrib_right[symmetric] simp del: space_T sets_T)
show "AE x in 𝔓. (∀n∈H. visit {n} {n} x ⟶ (∃j∈H. visit {j} {j} x)) ∧
((∃j∈H. visit {j} {j} x) ⟶ (∃!n. n ∈ H ∧ visit {n} {n} x))"
by (auto dest: visit_unique1)
qed simp_all
subsection ‹Probability that collaborators gain information›
definition "hit_C = Init`H ⋅ ev (HLD (Mix`C))"
definition "before_C B = (HLD (Jondo H)) suntil ((Jondo (B ∩ H)) ⋅ HLD (Mix ` C))"
lemma measurable_hit_C[measurable]: "Measurable.pred S hit_C"
by (simp add: hit_C_def)
lemma measurable_before_C[measurable]: "Measurable.pred S (before_C B)"
by (simp add: before_C_def)
lemma before_C:
assumes ω: "enabled Start ω"
shows "before_C B ω ⟷
((Init`H ⋅ (HLD (Mix`H) suntil (Mix`(B ∩ H) ⋅ HLD (Mix`C)))) or (Init`(B ∩ H) ⋅ HLD (Mix`C))) ω"
proof -
{ fix ω s assume "((HLD (Jondo H)) suntil (Jondo (B ∩ H) ⋅ HLD (Mix ` C))) ω"
"enabled s ω" "s ∈ Jondo H"
then have "(HLD (Mix ` H) suntil (Mix ` (B ∩ H) ⋅ (HLD (Mix ` C)))) ω"
proof (induction arbitrary: s)
case (base ω) then show ?case
by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix intro!: suntil.intros(1))
next
case (step ω) from step.prems step.hyps step.IH[of "shd ω"] show ?case
by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix
suntil.simps[of _ _ ω] enabled_End suntil_sconst)
qed }
note this[of "stl ω" "shd ω"]
moreover
{ fix ω s assume "(HLD (Mix ` H) suntil (Mix ` (B ∩ H) ⋅ (HLD (Mix ` C)))) ω"
"enabled s ω" "s ∈ Jondo H"
then have "((HLD (Jondo H)) suntil ((Jondo (B ∩ H)) ⋅ HLD (Mix ` C))) ω"
proof (induction arbitrary: s)
case (step ω) from step.prems step.hyps step.IH[of "shd ω"] show ?case
by (auto simp: HLD_iff enabled.simps[of _ ω] E_Init E_Mix
suntil.simps[of _ _ ω] enabled_End suntil_sconst)
qed (auto intro: suntil.intros simp: HLD_iff) }
note this[of "stl ω" "shd ω"]
ultimately show ?thesis
using assms
using ‹enabled Start ω›
unfolding before_C_def suntil.simps[of _ _ ω] enabled.simps[of _ ω]
by (auto simp: E_Start HLD_iff)
qed
lemma before_C_unique:
assumes ω: "before_C I1 ω" "before_C I2 ω" shows "I1 ∩ I2 ≠ {}"
using ω unfolding before_C_def
proof induction
case (base ω) then show ?case
by (auto simp add: suntil.simps[of _ _ ω] suntil.simps[of _ _ "stl ω"] HLD_iff)
next
case (step ω) then show ?case
by (auto simp add: suntil.simps[of _ _ ω] suntil.simps[of _ _ "stl ω"] HLD_iff)
qed
lemma hit_C_imp_before_C:
assumes "enabled Start ω" "hit_C ω" shows "before_C H ω"
proof -
let ?X = "Init`H ∪ Mix`H"
{ fix ω s assume "ev (HLD (Mix`C)) ω" "s∈?X" "enabled s ω"
then have "((HLD (Jondo H)) suntil (?X ⋅ HLD (Mix ` C))) (s ## ω)"
proof (induction arbitrary: s rule: ev_induct_strong)
case (step ω s) from step.IH[of "shd ω"] step.prems step.hyps show ?case
by (auto simp: enabled.simps[of _ ω] suntil_Stream E_Init E_Mix HLD_iff
enabled_End ev_sconst)
qed (auto simp: suntil_Stream) }
from this[of "stl ω" "shd ω"] assms show ?thesis
by (auto simp: before_C_def hit_C_def enabled.simps[of _ ω] E_Start)
qed
lemma before_C_single:
assumes "before_C I ω" shows "∃i∈I ∩ H. before_C {i} ω"
using assms unfolding before_C_def by induction (auto simp: HLD_iff intro: suntil.intros)
lemma before_C_imp_in_H: "before_C {i} ω ⟹ i ∈ H"
by (auto dest: before_C_single)
subsection ‹The probability that the sender hits a collaborator›
lemma Pr_hit_C: "𝒫(ω in 𝔓. hit_C ω) = (1 - p_H) / (1 - p_H * p_f)"
proof -
let ?P = "λx P. emeasure (T x) {ω∈space (T x). P ω}"
let ?M = "HLD (Mix ` C)" and ?I = "Init`H" and ?J = "Mix`H"
let ?φ = "(HLD ?J) aand not ?M"
{ fix s assume s: "s ∈ Jondo J"
have "AE ω in T s. ev ?M ω ⟷ (HLD ?J suntil ?M) ω"
using AE_T_enabled
proof eventually_elim
fix ω assume ω: "enabled s ω"
show "ev ?M ω ⟷ (HLD ?J suntil ?M) ω"
proof
assume "ev ?M ω"
from this ω s show "(HLD ?J suntil ?M) ω"
proof (induct arbitrary: s rule: ev_induct_strong)
case (step ω) then show ?case
by (auto simp: HLD_iff enabled.simps[of _ ω] suntil.simps[of _ _ ω] E_End E_Init E_Mix
enabled_End ev_sconst)
qed (auto simp: HLD_iff E_Init intro: suntil.intros)
qed (rule ev_suntil)
qed }
note ev_eq_suntil = this
have "?P Start hit_C = (∫⇧+x. ?P x (ev ?M) * indicator ?I x ∂N Start)"
unfolding hit_C_def by (rule emeasure_HLD_nxt) measurable
also have "… = (∫⇧+x. ennreal ((1 - p_H) / (1 - p_f * p_H)) * indicator ?I x ∂N Start)"
proof (intro nn_integral_cong ennreal_mult_right_cong refl)
fix x assume "indicator (Init ` H) x ≠ 0"
then have "x ∈ ?I"
by (auto split: split_indicator_asm)
{ fix j assume j: "j ∈ H"
with ev_eq_suntil[of "Mix j"] have "?P (Mix j) (ev ?M) = ?P (Mix j) ((HLD ?J) suntil ?M)"
by (intro emeasure_eq_AE) auto
also have "… = (((1 - p_H) * p_f)) / (1 - p_H * p_f)"
proof (rule emeasure_suntil_geometric)
fix s assume s: "s ∈ Mix ` H"
from s C_smaller show "?P s ?M = ennreal ((1 - p_H) * p_f)"
by (subst emeasure_HLD)
(auto simp add: emeasure_measure_pmf_finite sum.reindex subset_eq p_j_def H_compl)
from s show "emeasure (N s) (Mix`H) = p_H * p_f"
by (auto simp: emeasure_measure_pmf_finite sum.reindex p_H_def p_j_def)
qed (insert j, auto simp: HLD_iff p_H_p_f_less_1)
finally have "?P (Init j) (ev ?M) = (1 - p_H) / (1 - p_H * p_f)"
using p_f
by (subst emeasure_Init_eq_Mix)
(auto simp: ev_Stream AE_End ev_sconst HLD_iff mult_le_one divide_ennreal) }
then show "?P x (ev ?M) = (1 - p_H) / (1 - p_f * p_H)"
using ‹x ∈ ?I› by (auto simp: mult_ac)
qed
also have "… = ennreal ((1 - p_H) / (1 - p_H * p_f))"
using p_j_pos p_H p_H_p_f_less_1
by (subst nn_integral_cmult_indicator)
(auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq mult_ac
intro!: divide_nonneg_nonneg)
finally show ?thesis
by (simp add: measure_def mult_le_one)
qed
lemma before_C_imp_hit_C:
assumes "enabled Start ω" "before_C B ω"
shows "hit_C ω"
proof -
{ fix ω j assume "((HLD (Jondo H)) suntil (Jondo (B ∩ H) ⋅ HLD (Mix ` C))) ω"
"j ∈ H" "enabled (Mix j) ω"
then have "ev (HLD (Mix`C)) ω"
proof (induction arbitrary: j rule: suntil_induct_strong)
case (step ω) then show ?case
by (auto simp: enabled.simps[of _ ω] E_Mix enabled_End ev_sconst suntil_sconst HLD_iff)
qed auto }
from this[of "stl (stl ω)"] assms show "hit_C ω"
by (force simp: before_C_def hit_C_def E_Start HLD_iff E_Init
enabled.simps[of _ ω] ev.simps[of _ ω] suntil.simps[of _ _ ω]
enabled.simps[of _ "stl ω"] ev.simps[of _ "stl ω"] suntil.simps[of _ _ "stl ω"])
qed
lemma negE: "¬ P ⟹ P ⟹ False"
by blast
lemma Pr_visit_before_C:
assumes L: "L ⊆ H" and I: "I ⊆ H"
shows "𝒫(ω in 𝔓. visit I J ω ∧ before_C L ω ¦ hit_C ω ) =
(∑i∈I. p_i i) * card L * p_j * p_f + (∑i∈I ∩ L. p_i i) * (1 - p_H * p_f)"
proof -
let ?M = "Mix`H"
let ?P = "λx P. emeasure (T x) {ω∈space (T x). P ω}"
let ?V = "(visit I J aand before_C L) aand hit_C"
let ?U = "HLD ?M suntil (Mix`L ⋅ HLD (Mix`C))"
let ?L = "HLD (Mix`C)"
have IJ: "x ∈ I ⟹ x ∈ J" for x
using I by auto
have [simp, intro]: "finite I" "finite L"
using L I by (auto dest: finite_subset)
have "?P Start ?V = ?P Start ((Init`I ⋅ ?U) or (Init`(I ∩ L) ⋅ ?L))"
proof (rule emeasure_Collect_eq_AE)
show "AE ω in 𝔓. ?V ω ⟷ ((Init`I ⋅ ?U) or (Init`(I ∩ L) ⋅ ?L)) ω"
using AE_T_enabled AE_visit
proof eventually_elim
case (elim ω)
then show ?case
using before_C_imp_hit_C[of ω "L"] before_C[of ω "L"] I L
by (auto simp: visit_def HLD_iff Int_absorb2)
qed
show "Measurable.pred 𝔓 ((Init`I ⋅ ?U) or (Init`(I ∩ L) ⋅ ?L))"
by measurable
qed measurable
also have "… = ?P Start (Init`I ⋅ ?U) + ?P Start (Init`(I ∩ L) ⋅ ?L)"
using L I
apply (subst plus_emeasure)
apply (auto intro!: arg_cong2[where f=emeasure])
apply (subst (asm) suntil.simps)
apply (auto simp add: HLD_iff[abs_def] elim: suntil.cases)
done
also have "?P Start (Init`(I ∩ L) ⋅ ?L) = (∑i∈I∩L. p_i i * (1 - p_H))"
using L I C_smaller p_j_pos
apply (subst emeasure_HLD_nxt emeasure_HLD, simp)+
apply (subst nn_integral_indicator_finite)
apply (auto simp: emeasure_measure_pmf_finite sum.reindex next_prob_def sum.If_cases
Int_absorb2 H_compl2 ennreal_mult[symmetric] sum_nonneg
sum_distrib_left[symmetric] sum_distrib_right[symmetric]
intro!: sum.cong sum_nonneg)
apply (subst (asm) ennreal_inj)
apply (auto intro!: mult_nonneg_nonneg sum_nonneg sum.mono_neutral_left elim!: negE)
done
also have "?P Start (Init`I ⋅ ?U) = (∑i∈I. ?P (Init i) ?U * p_i i)"
using I
by (subst emeasure_HLD_nxt, simp)
(auto simp: nn_integral_indicator_finite sum.reindex emeasure_measure_pmf_finite
intro!: sum.cong[OF refl])
also have "… = (∑i∈I. ennreal (p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)) * p_i i)"
proof (intro sum.cong refl arg_cong2[where f="(*)"])
fix i assume "i ∈ I"
with I have i: "i ∈ H"
by auto
have "?P (Mix i) ?U = (p_f * p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f))"
unfolding before_C_def
proof (rule emeasure_suntil_geometric[where X="?M"])
show "Mix i ∈ ?M"
using i by auto
next
fix s assume "s ∈ ?M"
with p_f p_j_pos L C_smaller[THEN less_imp_le]
show "?P s (Mix`L ⋅ (HLD (Mix ` C))) = ennreal (p_f * p_f * (1 - p_H) * p_j * card L)"
apply (simp add: emeasure_HLD emeasure_HLD_nxt del: nxt.simps space_T)
apply (subst nn_integral_measure_pmf_support[of "Mix`L"])
apply (auto simp add: subset_eq emeasure_measure_pmf_finite sum.reindex H_compl p_j_def
ennreal_mult[symmetric] ennreal_of_nat_eq_real_of_nat)
done
next
fix s assume "s ∈ ?M" then show "emeasure (N s) ?M = ennreal (p_H * p_f)"
by (auto simp add: emeasure_measure_pmf_finite sum.reindex H_eq2)
next
show "AE ω in T t. ¬ ((Mix ` L ⋅ ?L) ⊓ (HLD (Mix ` H) ⊓ nxt ?U)) ω" for t
using L
apply (simp add: AE_T_iff[of _ t])
apply (subst AE_T_iff; simp)
apply (auto simp: HLD_iff suntil_Stream)
done
qed (insert L, auto simp: p_H_p_f_less_1 E_Mix)
then show "?P (Init i) ?U = p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)"
by (subst emeasure_Init_eq_Mix)
(auto simp: AE_End suntil_Stream divide_ennreal mult_le_one p_f)
qed
finally have *: "𝒫(ω in T Start. ?V ω) =
(p_f * (1 - p_H) * p_j * (card L) / (1 - p_H * p_f)) * (∑i∈I. p_i i) +
(∑i∈I ∩ L. p_i i) * (1 - p_H)"
using sum_nonneg [of "I ∩ L" p_i] sum_nonneg [of "I" p_i]
by (simp add: mult_ac measure_def sum_distrib_right[symmetric] sum_distrib_left[symmetric]
sum_divide_distrib[symmetric] IJ ennreal_mult[symmetric]
mult_le_one ennreal_plus[symmetric]
del: ennreal_plus)
show ?thesis
unfolding cond_prob_def Pr_hit_C *
using *
using p_f p_H p_j_pos p_H_p_f_less_1 by (simp add: divide_simps) (simp add: field_simps)
qed
lemma Pr_visit_eq_before_C:
"𝒫(ω in 𝔓. ∃j∈H. visit {j} J ω ∧ before_C {j} ω ¦ hit_C ω ) = 1 - (p_H - p_j) * p_f"
proof -
let ?V = "λj. visit {j} J aand before_C {j}" and ?H = "hit_C"
let ?J = "H"
have "𝒫(ω in 𝔓. (∃j∈?J. ?V j ω) ∧ ?H ω) = (∑j∈?J. 𝒫(ω in 𝔓. (?V j aand ?H) ω))"
proof (rule T.prob_sum)
show "AE ω in 𝔓. (∀j∈?J. (?V j aand ?H) ω ⟶ ((∃j∈?J. ?V j ω) ∧ ?H ω)) ∧
(((∃j∈?J. ?V j ω) ∧ ?H ω) ⟶ (∃!j. j∈?J ∧ (?V j aand ?H) ω))"
by (auto intro!: AE_I2 dest: visit_unique1)
qed auto
then have "𝒫(ω in 𝔓. (∃j∈?J. ?V j ω) ¦ ?H ω) = (∑j∈?J. 𝒫(ω in 𝔓. ?V j ω ¦ ?H ω))"
by (simp add: cond_prob_def sum_divide_distrib)
also have "… = p_j * p_f + (1 - p_H * p_f)"
by (simp add: Pr_visit_before_C sum_distrib_right[symmetric] sum.distrib)
finally show ?thesis
by (simp add: field_simps)
qed
lemma probably_innocent:
assumes approx: "1 / (2 * (p_H - p_j)) ≤ p_f" and "p_H ≠ p_j"
shows "𝒫(ω in 𝔓. ∃j∈H. visit {j} J ω ∧ before_C {j} ω ¦ hit_C ω ) ≤ 1 / 2"
unfolding Pr_visit_eq_before_C
proof -
have [simp]: "⋀n :: nat. 1 ≤ real n ⟷ 1 ≤ n" by auto
have "0 ≤ p_j" unfolding p_j_def by auto
then have "1 * p_j ≤ p_H"
unfolding H_eq2[symmetric] using C_smaller
by (intro mult_mono) (auto simp: Suc_le_eq card_Diff_subset not_le)
with ‹p_H ≠ p_j› have "p_j < p_H" by auto
with approx show "1 - (p_H - p_j) * p_f ≤ 1 / 2"
by (auto simp add: field_simps divide_le_eq split: if_split_asm)
qed
lemma Pr_before_C:
assumes L: "L ⊆ H"
shows "𝒫(ω in 𝔓. before_C L ω ¦ hit_C ω ) =
card L * p_j * p_f + (∑l∈L. p_i l) * (1 - p_H * p_f)"
proof -
have "𝒫(ω in 𝔓. before_C L ω ¦ hit_C ω ) =
𝒫(ω in 𝔓. visit H J ω ∧ before_C L ω ¦ hit_C ω )"
using AE_visit by (auto intro!: T.cond_prob_eq_AE)
also have "… = card L * p_j * p_f + (∑i∈L. p_i i) * (1 - p_H * p_f)"
using L by (subst Pr_visit_before_C[OF L order_refl]) (auto simp: Int_absorb1)
finally show ?thesis .
qed
lemma P_visit:
assumes I: "I ⊆ H"
shows "𝒫(ω in 𝔓. visit I J ω ¦ hit_C ω ) = (∑i∈I. p_i i)"
proof -
have "𝒫(ω in 𝔓. visit I J ω ¦ hit_C ω ) =
𝒫(ω in 𝔓. visit I J ω ∧ before_C H ω ¦ hit_C ω )"
proof (rule T.cond_prob_eq_AE)
show "AE x in 𝔓. hit_C x ⟶
visit I J x = (visit I J x ∧ before_C H x)"
using AE_T_enabled by eventually_elim (auto intro: hit_C_imp_before_C)
qed auto
also have "… = sum p_i I"
using I by (subst Pr_visit_before_C[OF order_refl]) (auto simp: Int_absorb2 field_simps p_H_def p_j_def)
finally show ?thesis .
qed
subsection ‹Probability space of hitting a collaborator›
definition "hC = uniform_measure 𝔓 {ω∈space 𝔓. hit_C ω}"
lemma emeasure_hit_C_not_0: "emeasure 𝔓 {ω ∈ space 𝔓. hit_C ω} ≠ 0"
using p_H p_H_p_f_less_1 unfolding Pr_hit_C T.emeasure_eq_measure by auto
lemma measurable_hC[measurable (raw)]:
"A ∈ sets S ⟹ A ∈ sets hC"
"f ∈ measurable M S ⟹ f ∈ measurable M hC"
"g ∈ measurable S M ⟹ g ∈ measurable hC M"
"A ∩ space S ∈ sets S ⟹ A ∩ space hC ∈ sets S"
unfolding hC_def uniform_measure_def
by simp_all
lemma vimage_Int_space_C[simp]:
"f -` {x} ∩ space hC = {ω∈space S. f ω = x}"
by (auto simp: hC_def)
sublocale hC: information_space hC 2
proof -
interpret hC: prob_space hC
unfolding hC_def
using emeasure_hit_C_not_0
by (intro prob_space_uniform_measure) auto
show "information_space hC 2"
by standard simp
qed
abbreviation
mutual_information_Pow_CP ("ℐ'(_ ; _')") where
"ℐ(X ; Y) ≡ hC.mutual_information 2 (count_space (X`space hC)) (count_space (Y`space hC)) X Y"
lemma simple_functionI:
assumes "finite (range f)"
assumes [measurable]: "⋀x. {ω∈space S. f ω = x} ∈ sets S"
shows "simple_function hC f"
using assms unfolding simple_function_def hC_def
by (simp add: vimage_def space_stream_space)
subsection ‹Estimate the information to the collaborators›
lemma measure_hC[simp]:
assumes A[measurable]: "A ∈ sets S"
shows "measure hC A = 𝒫(ω in 𝔓. ω ∈ A ¦ hit_C ω )"
unfolding hC_def cond_prob_def
using emeasure_hit_C_not_0 A
by (subst measure_uniform_measure) (simp_all add: T.emeasure_eq_measure Int_def conj_ac)
subsubsection ‹Setup random variables for mutual information›
definition "first_J ω = (THE i. visit {i} J ω)"
lemma first_J_eq:
"visit {i} J ω ⟹ first_J ω = i"
unfolding first_J_def by (intro the_equality) (auto dest: visit_unique1)
lemma AE_first_J:
"AE ω in 𝔓. visit {i} J ω ⟷ first_J ω = i"
using AE_visit
proof eventually_elim
fix ω assume "visit H J ω"
then obtain j where "visit {j} J ω" "j ∈ H"
by (auto simp: visit_def HLD_iff)
then show "visit {i} J ω ⟷ first_J ω = i"
by (auto dest: visit_unique1 first_J_eq)
qed
lemma measurbale_first_J[measurable]: "first_J ∈ measurable S (count_space UNIV)"
unfolding first_J_def[abs_def]
by (intro measurable_THE[where I=H])
(auto dest: visit_imp_in_H visit_unique1 intro: countable_finite)
definition "last_H ω = (THE i. before_C {i} ω)"
lemma measurbale_last_H[measurable]: "last_H ∈ measurable S (count_space UNIV)"
unfolding last_H_def[abs_def]
by (intro measurable_THE[where I=H])
(auto dest: before_C_single before_C_unique intro: countable_finite)
lemma last_H_eq:
"before_C {i} ω ⟹ last_H ω = i"
unfolding last_H_def by (intro the_equality) (auto dest: before_C_unique)
lemma last_H:
assumes "enabled Start ω" "hit_C ω"
shows "before_C {last_H ω} ω" "last_H ω ∈ H"
by (metis before_C_single hit_C_imp_before_C last_H_eq Int_iff assms)+
lemma AE_last_H:
"AE ω in 𝔓. hit_C ω ⟶ before_C {i} ω ⟷ last_H ω = i"
using AE_T_enabled
proof eventually_elim
fix ω assume "enabled Start ω" then show "hit_C ω ⟶ before_C {i} ω = (last_H ω = i)"
by (auto dest: last_H last_H_eq)
qed
lemma information_flow:
defines "h ≡ real (card H)"
assumes init_uniform: "⋀i. i ∈ H ⟹ p_i i = 1 / h"
shows "ℐ(first_J ; last_H) ≤ (1 - (h - 1) * p_j * p_f) * log 2 h"
proof -
let ?il = "λi l. 𝒫(ω in 𝔓. visit {i} J ω ∧ before_C {l} ω ¦ hit_C ω )"
let ?i = "λi. 𝒫(ω in 𝔓. visit {i} J ω ¦ hit_C ω )"
let ?l = "λl. 𝒫(ω in 𝔓. before_C {l} ω ¦ hit_C ω )"
from init_uniform have init_H: "⋀i. i ∈ H ⟹ p_i i = p_j / p_H"
by (simp add: p_j_def p_H_def h_def)
from h_def have "1/h = p_j/p_H" "h = p_H / p_j" "p_H = h * p_j"
by (auto simp: p_H_def p_j_def field_simps)
from C_smaller have h_pos: "0 < h"
by (auto simp add: card_gt_0_iff h_def)
let ?s = "(h - 1) * p_j"
let ?f = "?s * p_f"
from psubset_card_mono[OF _ C_smaller]
have "1 ≤ card J - card C"
by (simp del: C_le_J)
then have "1 ≤ h"
using C_smaller
by (simp add: h_def card_Diff_subset card_mono field_simps del: C_le_J)
have log_le_0: "?f * log 2 (p_H * p_f) ≤ ?f * log 2 1"
using p_H_p_f_less_1 p_H_p_f_pos p_j_pos p_f ‹1 ≤ h›
by (intro mult_left_mono log_le mult_nonneg_nonneg) auto
have "(h - 1) * p_j < 1"
using ‹1 ≤ h› C_smaller
by (auto simp: h_def p_j_def divide_less_eq card_Diff_subset card_mono)
then have 1: "(h - 1) * p_j * p_f < 1 * 1"
using p_f by (intro mult_strict_mono) auto
{ fix ω have "first_J ω ∈ H ∨ first_J ω = (THE x. False)"
apply (cases "∀i. ¬ visit {i} J ω")
apply (simp add: first_J_def)
apply (auto dest: visit_imp_in_H first_J_eq)
done }
then have range_fj: "range first_J ⊆ H ∪ {THE x. False}"
by auto
have sf_fj: "simple_function hC first_J"
by (rule simple_functionI) (auto intro: finite_subset[OF range_fj])
have sd_fj: "simple_distributed hC first_J ?i"
apply (rule hC.simple_distributedI[OF sf_fj])
apply (auto intro!: T.cond_prob_eq_AE)
apply (auto simp: space_stream_space)
using AE_first_J
apply eventually_elim
apply auto
done
{ fix ω have "last_H ω ∈ H ∨ last_H ω = (THE x. False)"
apply (cases "∀i. ¬ before_C {i} ω")
apply (simp add: last_H_def)
apply (auto dest: before_C_imp_in_H last_H_eq)
done }
then have range_lnc: "range last_H ⊆ H ∪ {THE x. False}"
by auto
have sf_lnc: "simple_function hC last_H"
by (rule simple_functionI) (auto intro: finite_subset[OF range_lnc])
have sd_lnc: "simple_distributed hC last_H ?l"
apply (rule hC.simple_distributedI[OF sf_lnc])
apply (auto intro!: T.cond_prob_eq_AE)
apply (auto simp: space_stream_space)
using AE_last_H
apply eventually_elim
apply auto
done
have sd_fj_lnc: "simple_distributed hC (λω. (first_J ω, last_H ω)) (λ(i, l). ?il i l)"
apply (rule hC.simple_distributedI)
apply (rule simple_function_Pair[OF sf_fj sf_lnc])
apply (auto intro!: T.cond_prob_eq_AE)
apply (auto simp: space_stream_space)
using AE_last_H AE_first_J
apply eventually_elim
apply auto
done
define c where "c = (SOME j. j ∈ C)"
have c: "c ∈ C"
using C_non_empty unfolding ex_in_conv[symmetric] c_def by (rule someI_ex)
let ?inner = "λi. ∑l∈H. ?il i l * log 2 (?il i l / (?i i * ?l l))"
{ fix i assume i: "i ∈ H"
with h_pos have card_idx: "real_of_nat (card (H - {i})) = p_H / p_j - 1"
by (auto simp add: p_j_def p_H_def h_def)
have neq0: "p_j ≠ 0" "p_H ≠ 0"
unfolding p_j_def p_H_def
using C_smaller i by auto
from i have "?inner i =
(∑l∈H - {i}. ?il i l * log 2 (?il i l / (?i i * ?l l))) +
?il i i * log 2 (?il i i / (?i i * ?l i))"
by (simp add: sum_diff)
also have "… =
(∑l∈H - {i}. p_j/p_H * p_j * p_f * log 2 (p_j * p_f / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))) +
p_j/p_H * (p_j * p_f + (1 - p_H * p_f)) * log 2 ((p_j * p_f + (1 - p_H * p_f)) / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))"
using i p_f p_j_pos p_H
apply (simp add: Pr_visit_before_C P_visit init_H Pr_before_C
del: sum_constant)
apply (simp add: divide_simps distrib_left)
apply (intro arg_cong2[where f="(*)"] refl arg_cong2[where f=log])
apply (auto simp: field_simps)
done
also have "… = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h"
using neq0 p_f by (simp add: card_idx field_simps ‹p_H = h * p_j›)
finally have "?inner i = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h" . }
then have "(∑i∈H. ?inner i) = ?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
using h_pos by (simp add: h_def[symmetric])
also have "… = ?f * log 2 (p_H * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
by (simp add: ‹h = p_H / p_j›)
also have "… ≤ (1 - ?f) * log 2 ((1 - ?f) * h)"
using log_le_0 by simp
also have "… ≤ (1 - ?f) * log 2 h"
using h_pos ‹1 ≤ h› 1 p_j_pos p_f
by (intro mult_left_mono log_le mult_pos_pos mult_nonneg_nonneg) auto
finally have "(∑i∈H. ?inner i) ≤ (1 - ?f) * log 2 h" .
also have "(∑i∈H. ?inner i) =
(∑(i, l)∈(first_J`space S) × (last_H`space S). ?il i l * log 2 (?il i l / (?i i * ?l l)))"
unfolding sum.cartesian_product
proof (safe intro!: sum.mono_neutral_cong_left del: DiffE DiffI)
show "finite ((first_J ` space S) × (last_H ` space S))"
using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
next
fix i assume "i ∈ H"
then have "visit {i} J (Init i ## Mix i ## sconst End)"
"before_C {i} (Init i ## Mix c ## sconst End)"
by (auto simp: before_C_def visit_def suntil_Stream HLD_iff c)
then show "i ∈ first_J ` space S" "i ∈ last_H ` space S"
by (auto simp: space_stream_space image_iff eq_commute dest!: first_J_eq last_H_eq)
next
fix i l assume "(i, l) ∈ first_J ` space S × last_H ` space S - H × H"
then have H: "i ∉ H ∨ l ∉ H"
by auto
have "𝒫(ω in 𝔓. (visit {i} J ω ∧ before_C {l} ω) ∧ hit_C ω) = 0"
using H by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
then show "?il i l * log 2 (?il i l / (?i i * ?l l)) = 0"
by (simp add: cond_prob_def)
qed
also have "… = ℐ(first_J ; last_H)"
unfolding sum.cartesian_product
apply (subst hC.mutual_information_simple_distributed[OF sd_fj sd_lnc sd_fj_lnc])
apply (simp add: hC_def)
proof (safe intro!: sum.mono_neutral_right imageI)
show "finite ((first_J ` space S) × (last_H ` space S))"
using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
next
fix i l assume "(first_J i, last_H l) ∉ (λx. (first_J x, last_H x)) ` space S"
moreover
{ fix i l assume "i ∈ H" "l ∈ H"
then have "visit {i} J (Init i ## Mix l ## Mix c ## sconst End)"
"before_C {l} (Init i ## Mix l ## Mix c ## sconst End)"
using c C_smaller by (auto simp: before_C_def visit_def HLD_iff suntil_Stream)
then have "first_J (Init i ## Mix l ## Mix c ## sconst End) = i"
"last_H (Init i ## Mix l ## Mix c ## sconst End) = l"
by (auto intro!: first_J_eq last_H_eq) }
note this[of "first_J i" "last_H l"]
ultimately have "(first_J i, last_H l) ∉ H×H"
by (auto simp: space_stream_space image_iff eq_commute) metis
then have "𝒫(ω in 𝔓. (visit {first_J i} J ω ∧ before_C {last_H l} ω) ∧ hit_C ω) = 0"
by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
then show "?il (first_J i) (last_H l) *
log 2 (?il (first_J i) (last_H l) / (?i (first_J i) * ?l (last_H l))) = 0"
by (simp add: cond_prob_def)
qed
finally show ?thesis by simp
qed
end
end
Theory Zeroconf_Analysis
section ‹Formalizing the IPv4-address allocation in ZeroConf›
theory Zeroconf_Analysis
imports "../Discrete_Time_Markov_Chain"
begin
declare UNIV_bool[simp]
subsection ‹Definition of a ZeroConf allocation run›
datatype zc_state = start
| probe nat
| ok
| error
lemma inj_probe: "inj_on probe X"
by (auto simp: inj_on_def)
text ‹Countability of @{typ zc_state} simplifies measurability of functions on @{typ zc_state}.›
instance zc_state :: countable
proof
have "countable ({start, ok, error} ∪ probe`UNIV)"
by auto
also have "{start, ok, error} ∪ probe`UNIV = UNIV"
using zc_state.nchotomy by auto
finally show "∃f::zc_state ⇒ nat. inj f"
using inj_on_to_nat_on[of "UNIV :: zc_state set"] by auto
qed
locale Zeroconf_Analysis =
fixes N :: nat and p q r e :: real
assumes p: "0 < p" "p < 1" and q: "0 < q" "q < 1"
assumes r[simp]: "0 ≤ r" and e[simp]: "0 ≤ e"
begin
lemma p_bounds[simp]: "0 ≤ p" "p ≤ 1"
using p by auto
lemma q_bounds[simp]: "0 ≤ q" "q ≤ 1"
using q by auto
abbreviation states where
"states ≡ probe ` {.. N} ∪ {start, ok, error}"
primrec τ :: "zc_state ⇒ zc_state pmf" where
"τ start = map_pmf (λTrue ⇒ probe 0 | False ⇒ ok) (bernoulli_pmf q)"
| "τ (probe n) = map_pmf (λTrue ⇒ (if n < N then probe (Suc n) else error) | False ⇒ start) (bernoulli_pmf p)"
| "τ ok = return_pmf ok"
| "τ error = return_pmf error"
primrec ρ :: "zc_state ⇒ zc_state ⇒ real" where
"ρ start = (λ_. 0) (probe 0 := r, ok := r * (N + 1))"
| "ρ (probe n) = (if n < N then (λ_. 0) (probe (Suc n) := r) else (λ_. 0) (error := e))"
| "ρ ok = (λ_. 0) (ok := 0)"
| "ρ error = (λ_. 0) (error := 0)"
lemma ρ_nonneg'[simp]: "0 ≤ ρ s t"
using r e by (cases s) auto
sublocale MC_with_rewards τ ρ "λs. 0"
proof qed (simp_all add: pair_measure_countable)
subsection ‹The allocation run is a rewarded DTMC›
abbreviation "E s ≡ set_pmf (τ s)"
lemma enabled_ok: "enabled ok ω ⟷ ω = sconst ok"
by (simp add: enabled_iff_sconst)
lemma finite_E[intro, simp]: "finite (E s)"
by (cases s) auto
lemma E_closed: "s ∈ states ⟹ E s ⊆ states"
using p q by (cases s) (auto split: bool.splits)
lemma enabled_error: "enabled error ω ⟷ ω = sconst error"
by (simp add: enabled_iff_sconst)
lemma pos_neg_q_pn: "0 < 1 - q * (1 - p^Suc N)"
proof -
have "p ^ Suc N ≤ 1 ^ Suc N"
using p by (intro power_mono) auto
with p q have "q * (1 - p^Suc N) < 1 * 1"
by (intro mult_strict_mono) (auto simp: field_simps simp del: power_Suc)
then show ?thesis by simp
qed
lemma to_error: assumes "n ≤ N" shows "(probe n, error) ∈ acc"
using ‹n ≤ N›
proof (induction rule: inc_induct)
case (step n') with p show ?case
by (intro rtrancl_trans[OF r_into_rtrancl step.IH]) auto
qed (insert p, auto)
subsection ‹Probability of a erroneous allocation›
definition "P_err s = 𝒫(ω in T s. ev (HLD {error}) (s ## ω))"
lemma P_err:
defines "p_start == (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
defines "p_probe == (λn. p ^ Suc (N - n) + (1 - p^Suc (N - n)) * p_start)"
assumes s: "s ∈ states - {ok, error}"
shows "P_err s = (case s of ok ⇒ 0 | error ⇒ 1 | probe n ⇒ p_probe n | start ⇒ p_start)"
(is "… = ?E s")
using s
proof (rule unique_les)
have [arith]: "0 ≤ p * (q * p ^ N)"
using p q by simp
have p_eq: "p_start = p_probe 0 * q"
"⋀n. n < N ⟹ p_probe n = p_probe (Suc n) * p + p_start * (1 - p)"
"p_probe N = p + p_start * (1 - p)"
using p q
by (auto simp: p_probe_def p_start_def power_Suc[symmetric] Suc_diff_Suc divide_simps
simp del: power_Suc)
(auto simp: field_simps)
fix s assume s: "s ∈ states - {ok, error}"
then show "?E s = (∫t. ?E t ∂τ s) + 0"
using p q by (auto intro: p_eq)
show "∃t∈{ok, error}. (s, t) ∈ acc"
using s q to_error by auto
from s show "P_err s = integral⇧L (measure_pmf (τ s)) P_err + 0"
unfolding P_err_def[abs_def] by (subst prob_T) (auto simp: ev_Stream simp del: UNIV_bool)
next
fix s assume "s ∈ {ok, error}" then show "P_err s = ?E s"
by (auto intro!: T.prob_eq_0_AE T.prob_Collect_eq_1[THEN iffD2]
simp: P_err_def AE_sconst ev_sconst HLD_iff ev_Stream T.prob_space
simp del: space_T sets_T )
qed (insert p q, auto intro!: integrable_measure_pmf_finite split: if_split_asm)
lemma P_err_start: "P_err start = (q * p ^ Suc N) / (1 - q * (1 - p ^ Suc N))"
by (simp add: P_err)
subsection ‹An allocation run terminates almost surely›
lemma states_closed:
assumes "s ∈ states"
assumes "(s, t) ∈ acc_on (- {error, ok})"
shows "t ∈ states"
using assms(2,1) p q by induction (auto split: if_split_asm)
lemma finite_reached:
assumes s: "s ∈ states" shows "finite (acc_on (- {error, ok}) `` {s})"
using states_closed[OF s]
by (rule_tac finite_subset[of _ states]) auto
lemma AE_reaches_error_or_ok:
assumes s: "s ∈ states"
shows "AE ω in T s. ev (HLD {error, ok}) ω"
proof (rule AE_T_ev_HLD)
{ fix t assume t: "(s, t) ∈ acc_on (- {error, ok})"
with states_closed[OF s t] to_error p q show "∃t'∈{error, ok}. (t, t') ∈ acc"
by auto }
qed (rule finite_reached[OF s])
subsection ‹Expected runtime of an allocation run›
definition "R s = (∫⇧+ ω. reward_until {error, ok} s ω ∂T s)"
definition "R' s = enn2real (R s)"
lemma R_iter: "s ≠ error ⟹ s ≠ ok ⟹ R s = (∫⇧+t. ennreal (ρ s t) + R t ∂τ s)"
unfolding R_def using T.emeasure_space_1
by (subst nn_integral_T)
(auto simp del: τ.simps ρ.simps simp add: AE_measure_pmf_iff nn_integral_add
intro!: nn_integral_cong_AE)
lemma R_finite:
assumes s: "s ∈ states"
shows "R s ≠ ∞"
unfolding R_def
proof (rule nn_integral_reward_until_finite)
{ fix t assume "(s, t) ∈ acc" from this s p q have "t ∈ states"
by induction (auto split: if_split_asm) }
then have "acc `` {s} ⊆ states"
by auto
then show "finite (acc `` {s})"
by (auto dest: finite_subset)
qed (auto simp: AE_reaches_error_or_ok[OF s])
lemma R_less_top: "s ∈ states ⟹ R s < top"
using R_finite[of s] by (subst less_top[symmetric]) simp
lemma R'_iter: assumes s: "s ∈ states" "s ≠ error" "s ≠ ok" shows "R' s = (∫t. ρ s t + R' t ∂τ s)"
unfolding R'_def R_iter[OF s(2,3)]
proof (rule enn2real_nn_integral_eq_integral)
have "t ∈ E s ⟹ R t < top" for t
using ‹s∈states› E_closed[of s] by (intro R_less_top) auto
then show "AE t in τ s. ennreal (ρ s t) + R t = ennreal (ρ s t + enn2real (R t))"
by (auto simp: AE_measure_pmf_iff intro!: ennreal_enn2real[symmetric])
show "(∫⇧+ t. ennreal (ρ s t) + R t ∂τ s) < ⊤"
unfolding R_iter[symmetric, OF s(2,3)] by (rule R_less_top) fact
qed auto
lemma cost_from_start:
"R' start =
(q * (r + p^Suc N * e + r * p * (1 - p^N) / (1 - p)) + (1 - q) * (r * Suc N)) /
(1 - q + q * p^Suc N)"
proof -
have ok_error: "R' ok = 0 ∧ R' error = 0"
unfolding R'_def R_def by (subst (1 2) reward_until_unfold[abs_def]) simp
then have R_start: "R' start = q * (r + R' (probe 0)) + (1 - q) * (r * (N + 1))"
using q r by (subst R'_iter) (simp_all add: field_simps)
have R_probe: "⋀n. n < N ⟹ R' (probe n) = p * R' (probe (Suc n)) + p * r + (1 - p) * R' start"
using p r by (subst R'_iter) (simp_all add: field_simps distrib_right)
have R_N: "R' (probe N) = p * e + (1 - p) * R' start"
using p e ok_error by (subst R'_iter) (auto simp: mult.commute )
{ fix n
assume "n ≤ N"
then have "R' (probe (N - n)) =
p ^ Suc n * e + (1 - p^n) * r * p / (1 - p) + (1 - p^Suc n) * R' start"
proof (induct n)
case 0 with R_N show ?case by simp
next
case (Suc n)
moreover then have "Suc (N - Suc n) = N - n" by simp
ultimately show ?case
using R_probe[of "N - Suc n"] p by (simp_all add: field_simps Suc)
qed }
from this[of N]
have [simp]: "R' (probe 0) = p ^ Suc N * e + (1 - p^N) * r * p / (1 - p) + (1 - p^Suc N) * R' start"
by simp
have "R' start - q * (1 - p^Suc N) * R' start =
q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * (N + 1))"
by (subst R_start) (simp_all add: field_simps)
then have "R' start = (q * (r + p^Suc N * e + (1 - p^N) * r * p / (1 - p)) + (1 - q) * (r * Suc N)) /
(1 - q * (1 - p^Suc N))"
using pos_neg_q_pn by (simp_all add: field_simps)
then show ?thesis
by (simp add: field_simps)
qed
end
interpretation ZC: Zeroconf_Analysis 2 "16 / 65024 :: real" "0.01" "0.002" "3600"
by standard auto
lemma "ZC.P_err start ≤ 1 / 10^12"
unfolding ZC.P_err_start by (simp add: power_divide power_one_over[symmetric])
lemma "ZC.R' start ≤ 0.007"
unfolding ZC.cost_from_start by (simp add: power_divide power_one_over[symmetric])
end
Theory Gossip_Broadcast
section ‹Formalization of the Gossip-Broadcast›
theory Gossip_Broadcast
imports "../Discrete_Time_Markov_Chain"
begin
lemma inj_on_upd_PiE:
assumes "i ∉ I" shows "inj_on (λ(x,f). f(i := x)) (M × (Π⇩E i∈I. A i))"
unfolding PiE_def
proof (safe intro!: inj_onI ext)
fix f g :: "'a ⇒ 'b" and x y :: 'b
assume *: "f(i := x) = g(i := y)" "f ∈ extensional I" "g ∈ extensional I"
then show "x = y" by (auto simp: fun_eq_iff split: if_split_asm)
fix i' from * ‹i ∉ I› show "f i' = g i'"
by (cases "i' = i") (auto simp: fun_eq_iff extensional_def split: if_split_asm)
qed
lemma sum_folded_product:
fixes I :: "'i set" and f :: "'s ⇒ 'i ⇒ 'a::{semiring_0, comm_monoid_mult}"
assumes "finite I" "⋀i. i ∈ I ⟹ finite (S i)"
shows "(∑x∈Pi⇩E I S. ∏i∈I. f (x i) i) = (∏i∈I. ∑s∈S i. f s i)"
using assms proof (induct I)
case empty then show ?case by simp
next
case (insert i I)
have *: "Pi⇩E (insert i I) S = (λ(x, f). f(i := x)) ` (S i × Pi⇩E I S)"
by (auto simp: PiE_def intro!: image_eqI ext dest: extensional_arb)
have "(∑x∈Pi⇩E (insert i I) S. ∏i∈insert i I. f (x i) i) =
sum ((λx. ∏i∈insert i I. f (x i) i) ∘ ((λ(x, f). f(i := x)))) (S i × Pi⇩E I S)"
unfolding * using insert by (intro sum.reindex) (auto intro!: inj_on_upd_PiE)
also have "… = (∑(a, x)∈(S i × Pi⇩E I S). f a i * (∏i∈I. f (x i) i))"
using insert by (force intro!: sum.cong prod.cong arg_cong2[where f="(*)"])
also have "… = (∑a∈S i. f a i * (∑x∈Pi⇩E I S. ∏i∈I. f (x i) i))"
by (simp add: sum.cartesian_product sum_distrib_left)
finally show ?case
using insert by (simp add: sum_distrib_right)
qed
subsection ‹Definition of the Gossip-Broadcast›
datatype state = listening | sending | sleeping
type_synonym sys_state = "(nat × nat) ⇒ state"
lemma state_UNIV: "UNIV = {listening, sending, sleeping}"
by (auto intro: state.exhaust)
locale gossip_broadcast =
fixes size :: nat and p :: real
assumes size: "0 < size"
assumes p: "0 < p" "p < 1"
begin
interpretation pmf_as_function .
definition states :: "sys_state set" where
"states = ({..< size} × {..< size}) →⇩E {listening, sending, sleeping}"
definition start :: sys_state where
"start = (λx∈{..< size}×{..< size}. listening)((0, 0) := sending)"
definition neighbour_sending where
"neighbour_sending s = (λ(x,y).
(x > 0 ∧ s (x - 1, y) = sending) ∨
(x < size ∧ s (x + 1, y) = sending) ∨
(y > 0 ∧ s (x, y - 1) = sending) ∨
(y < size ∧ s (x, y + 1) = sending))"
definition node_trans :: "sys_state ⇒ (nat × nat) ⇒ state ⇒ state ⇒ real" where
"node_trans g x s = (case s of
listening ⇒ (if neighbour_sending g x
then (λ_.0) (sending := p, sleeping := 1 - p)
else (λ_.0) (listening := 1))
| sending ⇒ (λ_.0) (sleeping := 1)
| sleeping ⇒ (λ_.0) (sleeping := 1))"
lemma node_trans_sum_eq_1[simp]:
"node_trans g x s' listening + (node_trans g x s' sending + node_trans g x s' sleeping) = 1"
by (simp add: node_trans_def split: state.split)
lemma node_trans_nonneg[simp]: "0 ≤ node_trans s x i j"
using p by (auto simp: node_trans_def split: state.split)
lift_definition proto_trans :: "sys_state ⇒ sys_state pmf" is
"λs s'. if s' ∈ states then (∏x∈{..< size}×{..< size}. node_trans s x (s x) (s' x)) else 0"
proof
let ?f = "λs s'. if s' ∈ states then (∏x∈{..< size}×{..< size}. node_trans s x (s x) (s' x)) else 0"
fix s show "∀t. 0 ≤ ?f s t"
using p by (auto intro!: prod_nonneg simp: node_trans_def split: state.split)
show "(∫⇧+t. ?f s t ∂count_space UNIV) = 1"
apply (subst nn_integral_count_space'[of states])
apply (simp_all add: prod_nonneg)
proof -
show "(∑x∈states. ∏xa∈{..<size} × {..<size}. node_trans s xa (s xa) (x xa)) = 1"
unfolding states_def by (subst sum_folded_product) simp_all
show "finite states"
by (auto simp: states_def intro!: finite_PiE)
qed
qed
end
subsection ‹The Gossip-Broadcast forms a DTMC›
sublocale gossip_broadcast ⊆ MC_syntax proto_trans .
end
Theory MDP_RP_Certification
section ‹Certification of Reachability Problems on MDPs›
theory MDP_RP_Certification
imports
"../MDP_Reachability_Problem"
"HOL-Library.IArray"
"HOL-Library.Code_Target_Numeral"
begin
context Reachability_Problem
begin
lemma p_ub':
fixes x
assumes 1: "s ∈ S" "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ (∑t∈S. pmf D t * x t) ≤ x s"
assumes 2: "⋀s. s ∈ S1 ⟹ x s ≠ 0 ⟹ (∃t∈S2. (s, t) ∈ (SIGMA s:S1. ⋃D∈K s. set_pmf D)⇧*)"
assumes 3: "⋀s. s ∈ S - S1 - S2 ⟹ x s = 0"
assumes 4: "⋀s. s ∈ S2 ⟹ x s = 1"
shows "enn2real (p s) ≤ x s"
proof (rule p_ub[OF 1 _ 4])
fix s assume "s ∈ S" "p s = 0" with 2[of s] p_pos[of s] p_S2[of s] 3[of s] show "x s = 0"
by (cases "x s = 0") auto
qed
lemma n_lb':
fixes x
assumes "wf R"
assumes 1: "s ∈ S" "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ x s ≤ (∑t∈S. pmf D t * x t)"
assumes 2: "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ x s ≠ 0 ⟹ ∃t∈D. ((t, s) ∈ R ∧ t ∈ S1 ∧ x t ≠ 0) ∨ t ∈ S2"
assumes 3: "⋀s. s ∈ S - S1 - S2 ⟹ x s = 0"
assumes 4: "⋀s. s ∈ S2 ⟹ x s = 1"
shows "x s ≤ enn2real (n s)"
proof (rule n_lb[OF 1 _ 4])
fix s assume *: "s ∈ S" "n s = 0"
show "x s = 0"
proof (rule ccontr)
assume "x s ≠ 0"
with * n_S2[of s] n_nS12[of s] 3[of s] have "s ∈ S1"
by (metis DiffI zero_neq_one)
have "0 < n s"
by (intro n_pos[of "λs. x s ≠ 0", OF ‹x s ≠ 0› ‹s ∈ S1› ‹wf R›])
(metis zero_less_one n_S2 2)
with ‹n s = 0› show False by auto
qed
qed
end
no_notation Stream.snth (infixl "!!" 100)
subsection ‹Computable representation›
record mdp_reachability_problem =
state_count :: nat
distrs :: "(nat × rat) list list iarray"
states1 :: "bool iarray"
states2 :: "bool iarray"
record 'a RP_sub_cert =
solution :: "rat iarray"
witness :: "('a × nat) iarray"
record RP_cert =
pos_cert :: "(nat × nat) RP_sub_cert"
neg_cert :: "nat list RP_sub_cert"
definition "sparse_mult sx y = sum_list (map (λ(n, x). x * y !! n) sx)"
primrec lookup where
"lookup d [] x = d"
| "lookup d (y#ys) x = (if fst y = x then snd y else lookup d ys x)"
lemma lookup_eq_map_of: "lookup d xs x = (case map_of xs x of Some x ⇒ x | None ⇒ d)"
by (induct xs) simp_all
lemma lookup_in_set:
"distinct (map fst xs) ⟹ x ∈ set xs ⟹ lookup d xs (fst x) = snd x"
unfolding lookup_eq_map_of by (subst map_of_is_SomeI[where y="snd x"]) simp_all
lemma lookup_not_in_set:
"x ∉ fst ` set xs ⟹ lookup d xs x = d"
unfolding lookup_eq_map_of
by (subst map_of_eq_None_iff[of xs x, THEN iffD2]) auto
lemma lookup_nonneg:
"(⋀x v. (x, v) ∈ set xs ⟹ 0 ≤ v) ⟹ (0::'a::ordered_comm_monoid_add) ≤ lookup 0 xs x"
apply (induction xs)
apply simp
apply force
done
lemma sparse_mult_eq_sum_lookup:
fixes xs :: "(nat × 'a::comm_semiring_1) list"
assumes "list_all (λ(n, x). n < M) xs" "distinct (map fst xs)"
shows "sparse_mult xs y = (∑i<M. lookup 0 xs i * y !! i)"
proof -
from ‹distinct (map fst xs)› have "distinct xs" "inj_on fst (set xs)"
by (simp_all add: distinct_map)
then have "sparse_mult xs y = (∑x∈set xs. snd x * y !! fst x)"
by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
also have "… = (∑x∈set xs. lookup 0 xs (fst x) * y !! fst x)"
by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
also have "… = (∑x∈fst ` set xs. lookup 0 xs x * y !! x)"
using ‹inj_on fst (set xs)› by (simp add: sum.reindex)
also have "… = (∑x<M. lookup 0 xs x * y !! x)"
using assms(1)
by (intro sum.mono_neutral_cong_left)
(auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
finally show ?thesis .
qed
lemma sum_list_eq_sum_lookup:
fixes xs :: "(nat × 'a::comm_semiring_1) list"
assumes "list_all (λ(n, x). n < M) xs" "distinct (map fst xs)"
shows "sum_list (map snd xs) = (∑i<M. lookup 0 xs i)"
proof -
from ‹distinct (map fst xs)› have "distinct xs" "inj_on fst (set xs)"
by (simp_all add: distinct_map)
then have "sum_list (map snd xs) = (∑x∈set xs. snd x)"
by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
also have "… = (∑x∈set xs. lookup 0 xs (fst x))"
by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
also have "… = (∑x∈fst ` set xs. lookup 0 xs x)"
using ‹inj_on fst (set xs)› by (simp add: sum.reindex)
also have "… = (∑x<M. lookup 0 xs x)"
using assms(1)
by (intro sum.mono_neutral_cong_left)
(auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
finally show ?thesis .
qed
definition
"valid_mdp_rp mdp ⟷
0 < state_count mdp ∧
IArray.length (distrs mdp) = state_count mdp ∧
IArray.length (states1 mdp) = state_count mdp ∧
IArray.length (states2 mdp) = state_count mdp ∧
(∀i<state_count mdp. ¬ (states1 mdp !! i ∧ states2 mdp !! i) ∧
list_all (λds. distinct (map fst ds) ∧ list_all (λ(n, x). 0 ≤ x ∧ n < state_count mdp) ds ∧
sum_list (map snd ds) = 1) (distrs mdp !! i) ∧
¬ List.null (distrs mdp !! i))"
definition
"valid_sub_cert mdp c ord check ⟷
IArray.length (witness c) = state_count mdp ∧
IArray.length (solution c) = state_count mdp ∧
(∀i<state_count mdp.
if states2 mdp !! i then solution c !! i = 1
else if states1 mdp !! i then 0 ≤ solution c !! i ∧
(list_all (λds. ord (sparse_mult ds (solution c)) (solution c !! i)) (distrs mdp !! i)) ∧
(0 < solution c !! i ⟶ check (distrs mdp !! i) (witness c !! i))
else solution c !! i = 0)"
definition
"valid_pos_cert mdp c ⟷
valid_sub_cert mdp c (≤)
(λD ((j, a), n). j < state_count mdp ∧ snd (witness c !! j) < n ∧ 0 < solution c !! j ∧
a < length D ∧ lookup 0 (D ! a) j ≠ 0)"
definition
"valid_neg_cert mdp c ⟷
valid_sub_cert mdp c (≥)
(λD (J, n). list_all2 (λj d. j < state_count mdp ∧ snd (witness c !! j) < n ∧
lookup 0 d j ≠ 0 ∧ 0 < solution c !! j) J D)"
definition
"valid_cert mdp c ⟷ valid_pos_cert mdp (pos_cert c) ∧ valid_neg_cert mdp (neg_cert c)"
lemma valid_mdp_rpD_length:
assumes "valid_mdp_rp mdp"
shows "0 < state_count mdp" "IArray.length (distrs mdp) = state_count mdp"
"IArray.length (states1 mdp) = state_count mdp" "IArray.length (states2 mdp) = state_count mdp"
using assms by (auto simp: valid_mdp_rp_def)
lemma valid_mdp_rpD:
assumes "valid_mdp_rp mdp" "i < state_count mdp"
shows "¬ (states1 mdp !! i ∧ states2 mdp !! i)"
and "⋀ds n x. ds ∈ set (distrs mdp !! i) ⟹ (n, x) ∈ set ds ⟹ n < state_count mdp"
and "⋀ds n x. ds ∈ set (distrs mdp !! i) ⟹ (n, x) ∈ set ds ⟹ 0 ≤ x"
and "⋀ds. ds ∈ set (distrs mdp !! i) ⟹ sum_list (map snd ds) = 1"
and "⋀ds. ds ∈ set (distrs mdp !! i) ⟹ distinct (map fst ds)"
and "distrs mdp !! i ≠ []"
using assms by (auto simp: valid_mdp_rp_def list_all_iff List.null_def elim!: allE[of _ i])
lemma valid_mdp_rp_sparse_mult:
assumes "valid_mdp_rp mdp" "i < state_count mdp" "ds ∈ set (distrs mdp !! i)"
shows "sparse_mult ds y = (∑i<state_count mdp. lookup 0 ds i * y !! i)"
using valid_mdp_rpD(2,5)[OF assms] by (intro sparse_mult_eq_sum_lookup) (auto simp: list_all_iff)
lemma valid_sub_certD:
assumes "valid_mdp_rp mdp" "valid_sub_cert mdp c ord check" "i < state_count mdp"
shows "¬ states1 mdp !! i ⟹ ¬ states2 mdp !! i ⟹ solution c !! i = 0"
and "states2 mdp !! i ⟹ solution c !! i = 1"
and "states1 mdp !! i ⟹ 0 ≤ solution c !! i"
and "⋀ds. states1 mdp !! i ⟹ ds ∈ set (distrs mdp !! i) ⟹ ord (sparse_mult ds (solution c)) (solution c !! i)"
and "⋀ds. states1 mdp !! i ⟹ 0 < solution c !! i ⟶ check (distrs mdp !! i) (witness c !! i)"
using assms(2,3) valid_mdp_rpD(1)[OF assms(1,3)]
by (auto simp add: valid_sub_cert_def list_all_iff)
lemma valid_pos_certD:
assumes "valid_mdp_rp mdp" "valid_pos_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
"0 < solution c !! i" "witness c !! i = ((j, a), n)"
shows "snd (witness c !! j) < n ∧ j < state_count mdp ∧ a < length (distrs mdp !! i) ∧
lookup 0 ((distrs mdp !! i) ! a) j ≠ 0 ∧ 0 < solution c !! j"
using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_pos_cert_def] assms(3,4)] assms(5-) by auto
lemma valid_neg_certD:
assumes "valid_mdp_rp mdp" "valid_neg_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
"0 < solution c !! i" "witness c !! i = (js, n)"
shows "list_all2 (λj ds. j < state_count mdp ∧ snd (witness c !! j) < n ∧ lookup 0 ds j ≠ 0 ∧ 0 < solution c !! j) js (distrs mdp !! i)"
using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_neg_cert_def] assms(3)] assms(4-) by auto
context
fixes mdp c
assumes rp: "valid_mdp_rp mdp"
assumes cert: "valid_cert mdp c"
begin
interpretation pmf_as_function .
abbreviation "S ≡ {..< state_count mdp}"
abbreviation "S1 ≡ {i. i < state_count mdp ∧ (states1 mdp) !! i}"
abbreviation "S2 ≡ {i. i < state_count mdp ∧ (states2 mdp) !! i}"
lift_definition K :: "nat ⇒ nat pmf set" is
"λi. if i < state_count mdp then
{ (λj. of_rat (lookup 0 D j) :: real) | D. D ∈ set (distrs mdp !! i) }
else { indicator {0} }"
proof (auto split: if_split_asm simp del: IArray.sub_def)
fix n D assume n: "n < state_count mdp" and D: "D ∈ set (distrs mdp !! n)"
from valid_mdp_rpD(3)[OF rp this] show nn: "⋀i. 0 ≤ lookup 0 D i"
by (auto simp add: lookup_eq_map_of split: option.split dest: map_of_SomeD)
show "(∫⇧+ x. ennreal (real_of_rat (lookup 0 D x)) ∂count_space UNIV) = 1"
using valid_mdp_rpD(2,3,4,5)[OF rp n D]
apply (subst nn_integral_count_space'[of "{..< state_count mdp}"])
apply (auto intro: nn lookup_not_in_set simp: of_rat_sum[symmetric] lookup_nonneg)
apply (subst sum_list_eq_sum_lookup[symmetric])
apply (auto simp: list_all_iff lookup_eq_map_of split: option.split)
done
next
show "(∫⇧+ x. ennreal (indicator {0} x) ∂count_space UNIV) = 1"
by (subst nn_integral_count_space'[of "{0}"]) auto
qed
interpretation MDP: Reachability_Problem K S S1 S2
proof
show "S1 ∩ S2 = {}" "S1 ⊆ S" "S2 ⊆ S"
using valid_mdp_rpD(1)[OF rp] by auto
show "finite S" "S ≠ {}"
using ‹valid_mdp_rp mdp› by (auto simp add: valid_mdp_rp_def)
show "⋀s. K s ≠ {}"
using valid_mdp_rpD(6)[OF rp] by transfer simp
show "⋀s. finite (K s)"
by transfer simp
fix s assume "s ∈ S" then show "(⋃D∈K s. set_pmf D) ⊆ S"
using valid_mdp_rpD(2)[OF rp]
by transfer (auto simp: lookup_eq_map_of split: option.splits dest!: map_of_SomeD)
qed
definition "P_max s = enn2real (MDP.p s)"
definition "P_min s = enn2real (MDP.n s)"
lemma
assumes "i < state_count mdp"
shows P_max: "P_max i ≤ real_of_rat (solution (pos_cert c) !! i)" (is ?max)
and P_min: "P_min i ≥ real_of_rat (solution (neg_cert c) !! i)" (is ?min)
proof -
have "valid_pos_cert mdp (pos_cert c)" "valid_neg_cert mdp (neg_cert c)"
using ‹valid_cert mdp c› by (auto simp: valid_cert_def)
note pos = this(1)[unfolded valid_pos_cert_def] and neg = this(2)[unfolded valid_neg_cert_def]
let ?x = "λs. real_of_rat (solution (pos_cert c) !! s)"
have "enn2real (MDP.p i) ≤ ?x i"
proof (rule MDP.p_ub')
show "i ∈ S" using assms by simp
next
fix s D assume "s ∈ S1" "D ∈ K s"
then obtain j where j: "j < length (distrs mdp !! s)"
"⋀i. i < state_count mdp ⟹ pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
by transfer (auto simp: in_set_conv_nth)
with valid_sub_certD(4)[OF ‹valid_mdp_rp mdp› pos, of s "distrs mdp !! s ! j"] ‹s ∈ S1›
valid_mdp_rp_sparse_mult[OF ‹valid_mdp_rp mdp›, of s "distrs mdp !! s ! j" "solution (pos_cert c)"]
show "(∑t∈S. pmf D t * ?x t) ≤ ?x s"
by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
next
fix s a assume "s ∈ S2" then show "?x s = 1"
using valid_sub_certD[OF ‹valid_mdp_rp mdp› pos] by simp
next
fix s define X where "X = (SIGMA s:S1. ⋃D∈K s. set_pmf D)"
assume "s ∈ S1" "?x s ≠ 0"
with valid_sub_certD(3)[OF rp pos, of s]
have "0 < ?x s"
by simp
with ‹s∈S1› show "∃t∈S2. (s, t) ∈ X⇧*"
proof (induction n≡"snd (witness (pos_cert c) !! s)" arbitrary: s rule: less_induct)
case (less s)
obtain t a n where eq: "witness (pos_cert c) !! s = ((t, a), n)"
by (metis prod.exhaust)
from valid_pos_certD[OF rp ‹valid_pos_cert mdp (pos_cert c)› _ _ _ this] less.prems
have ord: "snd (witness (pos_cert c) !! t) < snd (witness (pos_cert c) !! s)"
and t: "lookup 0 (distrs mdp !! s ! a) t ≠ 0" "0 < ?x t" "t∈S" "a < length (distrs mdp !! s)"
unfolding eq by auto
with ‹s∈S1› have X: "(s, t) ∈ X"
unfolding X_def
by (transfer fixing: s t a c)
(auto simp: X_def in_set_conv_nth
intro!: exI[of _ "λj. real_of_rat (lookup 0 (distrs mdp !! s ! a) j)"]
exI[of _ "distrs mdp !! s ! a"] exI[of _ a])
show ?case
proof cases
assume "t ∈ S1"
with less.hyps[OF ord _ ‹0 < ?x t›] X show ?thesis
by auto
next
assume "t ∉ S1"
with valid_sub_certD[OF ‹valid_mdp_rp mdp› pos, of t] ‹0 < ?x t› ‹t∈S›
have "t ∈ S2"
by auto
with X show ?thesis
by auto
qed
qed
next
fix s assume "s ∈ S - S1 - S2" then show "?x s = 0"
using valid_sub_certD(1)[OF ‹valid_mdp_rp mdp› pos, of s] by simp
qed
then show ?max
by (simp add: P_max_def)
let ?x = "λs. real_of_rat (solution (neg_cert c) !! s)"
have "?x i ≤ enn2real (MDP.n i)"
proof (rule MDP.n_lb')
show "i ∈ S" using assms by simp
next
fix s D assume "s ∈ S1" "D ∈ K s"
then obtain j where j: "j < length (distrs mdp !! s)"
"⋀i. i < state_count mdp ⟹ pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
by transfer (auto simp: in_set_conv_nth)
with valid_sub_certD(4)[OF ‹valid_mdp_rp mdp› neg, of s "distrs mdp !! s ! j"] ‹s ∈ S1›
valid_mdp_rp_sparse_mult[OF ‹valid_mdp_rp mdp›, of s "distrs mdp !! s ! j" "solution (neg_cert c)"]
show "?x s ≤ (∑t∈S. pmf D t * ?x t)"
by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
next
fix s a assume "s ∈ S2" then show "?x s = 1"
using valid_sub_certD[OF ‹valid_mdp_rp mdp› neg] by simp
next
show "wf ((S × S ∩ {(s, t). snd (witness (neg_cert c) !! t) < snd (witness (neg_cert c) !! s)})¯)" (is "wf ?F")
using MDP.S_finite
by (intro finite_acyclic_wf_converse acyclicI_order[where f="λs. snd (witness (neg_cert c) !! s)"]) auto
fix s D assume 2: "s ∈ S1" "D ∈ K s" and "?x s ≠ 0"
then have "0 < ?x s"
using valid_sub_certD(3)[OF ‹valid_mdp_rp mdp› neg, of s] by auto
from 2 obtain a where a: "a < length (distrs mdp !! s)"
"⋀i. i < state_count mdp ⟹ pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! a) i)"
by transfer (auto simp: in_set_conv_nth)
obtain js n where eq: "witness (neg_cert c) !! s = (js, n)"
by (metis prod.exhaust)
from valid_neg_certD[OF ‹valid_mdp_rp mdp› ‹valid_neg_cert mdp (neg_cert c)› _ _ _ eq] a ‹s ∈ S1› ‹0 < ?x s›
have *: "length js = length (distrs mdp !! s)" "js ! a ∈ S"
"snd (witness (neg_cert c) !! (js ! a)) < snd (witness (neg_cert c) !! s)"
"lookup 0 (distrs mdp !! s ! a) (js ! a) ≠ 0"
"0 < ?x (js ! a)"
unfolding eq by (auto dest: list_all2_nthD2 list_all2_lengthD)
with a ‹s ∈ S1› have js_a: "js ! a ∈ D" "(js ! a, s) ∈ ?F"
by (auto simp: set_pmf_iff)
show "∃t∈D. (t, s) ∈ ?F ∧ t ∈ S1 ∧ ?x t ≠ 0 ∨ t ∈ S2"
proof cases
assume "js ! a ∈ S1" with js_a ‹0 < ?x (js ! a)› show ?thesis by auto
next
assume "js ! a ∉ S1"
with ‹0 < ?x (js ! a)› ‹js!a ∈ S› valid_sub_certD[OF rp neg, of "js ! a"]
have "js ! a ∈ S2"
by (auto simp: less_le)
with ‹js ! a ∈ D› show ?thesis
by auto
qed
next
fix s assume "s ∈ S - S1 - S2" then show "?x s = 0"
using valid_sub_certD(1)[OF ‹valid_mdp_rp mdp› neg, of s] by simp
qed
then show ?min
by (simp add: P_min_def)
qed
end
end
Theory MDP_RP
section ‹Value Iteration for Reachability Probabilities of MDPs›
theory MDP_RP
imports "../Markov_Models"
begin
subsection ‹Auxiliary Theorems›
lemma INF_Union_eq: "(INF x∈⋃A. f x) = (INF a∈A. INF x∈a. f x)" for f :: "_ ⇒ 'a::complete_lattice"
by (auto intro!: antisym INF_greatest intro: INF_lower2)
lemma lift_option_eq_None: "lift_option f A B = None ⟷ (A ≠ None ⟶ B = None)"
by (cases A; cases B; auto)
lemma lift_option_eq_Some: "lift_option f A B = Some y ⟷ (∃a b. A = Some a ∧ B = Some b ∧ y = f a b)"
by (cases A; cases B; auto)
lemma ord_option_Some1_iff: "ord_option R (Some a) y ⟷ (∃b. y = Some b ∧ R a b)"
by (cases y; auto)
lemma ord_option_Some2_iff: "ord_option R x (Some b) ⟷ (∀a. x = Some a ⟶ R a b)"
by (cases x; auto)
lemma sym_Restr: "sym A ⟹ sym (Restr A S)"
by (auto simp: sym_def)
lemma trans_Restr: "trans A ⟹ trans (Restr A S)"
by (auto simp: trans_def)
lemma image_eq_singleton_iff: "inj_on f S ⟹ f ` S = {y} ⟷ (∃x. S = {x} ∧ y = f x)"
by (auto elim: inj_img_insertE)
lemma quotient_eq_singleton: "equiv A r ⟹ A // r = {B} ⟹ B = A"
using Union_quotient[of A r] by auto
lemma UN_singleton_image: "(⋃x∈A. {f x}) = f ` A"
by auto
lemma image_eq_singeltonD: "f ` A = {x} ⟹ ∀a∈A. f a = x"
by auto
lemma fun_ord_refl: "reflp ord ⟹ reflp (fun_ord ord)"
by (auto simp: fun_ord_def reflp_def)
lemma fun_ord_trans: "transp ord ⟹ transp (fun_ord ord)"
by (fastforce simp: fun_ord_def transp_def)
lemma fun_ord_antisym: "antisymp ord ⟹ antisymp (fun_ord ord)"
by (fastforce simp: fun_ord_def antisymp_def)
lemma fun_ord_combine:
"fun_ord ord a b ⟹ fun_ord ord c d ⟹ (⋀s. ord (a s) (b s) ⟹ ord (c s) (d s) ⟹ ord (e s) (f s)) ⟹ fun_ord ord e f"
by (auto simp: fun_ord_def)
lemma not_all_eq: "~ (∀y. x ≠ y)"
by auto
lemma ball_vimage_iff: "(∀x∈f -` X. P x) ⟷ (∀x. f x ∈ X ⟶ P x)"
by auto
lemma UN_If_cases: "(⋃x∈X. if P x then A x else B x) = (⋃x∈{x∈X. P x}. A x) ∪ (⋃x∈{x∈X. ¬ P x}. B x)"
by (auto split: if_splits)
lemma (in Reachability_Problem) n_eq_0_closed:
assumes s: "s ∈ S'" and S': "S' ⊆ S" "S' ∩ S2 = {}" and closed: "⋀s. s ∈ S' ⟹ ∃D∈K s. D ⊆ S'"
shows "n s = 0"
proof -
from closed obtain ct where ct: "⋀s. s ∈ S' ⟹ ct s ∈ K s" "⋀s. s ∈ S' ⟹ ct s ⊆ S'"
by metis
define cfg where "cfg = memoryless_on (λs. if s ∈ S' then ct s else arb_act s)"
have cfg_on: "cfg s ∈ cfg_on s" for s
unfolding cfg_def using ct by (intro memoryless_on_cfg_onI) auto
have state_cfg[simp]: "state (cfg s) = s" for s
unfolding cfg_def by (intro state_memoryless_on)
have action_cfg[simp]: "action (cfg s) = (if s ∈ S' then ct s else arb_act s)" for s
unfolding cfg_def by (intro action_memoryless_on)
have cont_cfg[simp]: "s ∈ S' ⟹ t ∈ ct s ⟹ cont (cfg s) t = cfg t" for s t
unfolding cfg_def by (intro cont_memoryless_on) auto
from s have "v (cfg s) = 0"
proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
case (valid cfg') with cfg_on s S' show ?case
by (auto simp: valid_cfg_def)
next
case (nS2 cfg') with S' show ?case
by auto
next
case (cont cfg') with S' ct show ?case
by (force simp: set_K_cfg)
qed
show "n s = 0"
proof (rule n_eq_0)
show "s ∈ S" using s S' by auto
qed fact+
qed
lemma (in Reachability_Problem) n_lb_ennreal:
fixes x
assumes "s ∈ S"
assumes solution: "⋀s D. s ∈ S1 ⟹ D ∈ K s ⟹ x s ≤ (∑t∈S. ennreal (pmf D t) * x t)"
assumes solution_n0: "⋀s. s ∈ S ⟹ n s = 0 ⟹ x s = 0"
assumes solution_S2: "⋀s. s ∈ S2 ⟹ x s = 1"
and le_1: "⋀s. s ∈ S ⟹ x s ≤ 1"
shows "x s ≤ n s" (is "_ ≤ ?y s")
proof -
have x_less_top[simp]: "s ∈ S ⟹ x s < top" for s
using le_1[of s] by (auto simp: less_top[symmetric] top_unique)
have "enn2real (x s) ≤ enn2real (n s)"
apply (rule n_lb[OF ‹s∈S›])
subgoal for s D
by (rule ennreal_le_iff[THEN iffD1])
(use S1 in ‹auto intro!: sum_nonneg simp add: subset_eq solution sum_ennreal[symmetric] ennreal_mult simp del: sum_ennreal›)
apply (auto simp: solution_n0 solution_S2)
done
with ‹s∈S› show ?thesis
by (subst (asm) ennreal_le_iff[symmetric]) (simp_all add: real_n)
qed
lifting_forget pmf_as_function.pmf.lifting
text ‹
Type to describe MDP components. The support (i.e. elements which are not mapped to an empty
set) is the set of states of the component.
Most of this is from:
Formal verification of probabilistic systems
Luca de Alfaro (PhD thesis, 1997)
and
Reachability in MDPs: Refining Convergence of Value Iteration
Serge Haddad and Benjamin Monmege (2014)
›
typedef 's mdpc = "UNIV :: ('s ⇀ 's pmf set) set"
by auto
setup_lifting type_definition_mdpc
lift_definition states :: "'s mdpc ⇒ 's set"
is dom .
declare [[coercion states]]
lift_definition actions :: "'s mdpc ⇒ 's ⇒ 's pmf set"
is "λf s. case f s of None ⇒ {} | Some a ⇒ a" .
lemma in_states: "actions φ s ≠ {} ⟹ s ∈ states φ"
by transfer auto
lemma mdpc_eqI: "states φ = states ψ ⟹ (⋀s. s ∈ states φ ⟹ actions φ s = actions ψ s) ⟹ φ = ψ"
apply transfer
apply (rule ext)
subgoal premises prems for φ ψ x
using prems(1) prems(2)[of x]
by (cases "x ∈ dom φ") (auto simp: fun_eq_iff split: option.splits)
done
lift_definition map_mdpc :: "('s ⇒ 't) ⇒ 's mdpc ⇒ 't mdpc"
is "λm f s. if f ` (m -` {s}) ⊆ {None} then None else Some {map_pmf m d | d A t. m t = s ∧ f t = Some A ∧ d ∈ A}" .
lemma states_map_mdpc: "states (map_mdpc f M) = f ` (states M)"
by (transfer fixing: f) (auto simp: subset_eq image_iff dom_def split: if_splits)
lemma actions_map_mdpc_eq_Collect: "actions (map_mdpc f M) s = {map_pmf f d | d t. f t = s ∧ d ∈ actions M t}"
by transfer (force simp: subset_eq split: option.splits)
lemma actions_map_mdpc: "actions (map_mdpc f M) s = map_pmf f ` (⋃t∈f -` {s}. actions M t)"
by (auto simp: actions_map_mdpc_eq_Collect)
lemma map_mdpc_compose: "map_mdpc f (map_mdpc g M) = map_mdpc (f ∘ g) M"
by (intro mdpc_eqI)
(auto simp add: states_map_mdpc image_comp actions_map_mdpc image_UN map_pmf_compose[symmetric]
vimage_comp[symmetric])
lemma map_mdpc_id: "map_mdpc id = id"
by (auto simp: fun_eq_iff states_map_mdpc actions_map_mdpc intro!: mdpc_eqI)
lemma finite_states_map: "finite (states M) ⟹ finite (map_mdpc f M)"
by (simp add: states_map_mdpc)
lemma finite_actions_map:
assumes "finite (states M)" "⋀s. finite (actions M s)" shows "finite (actions (map_mdpc f M) s)"
proof -
have "(⋃x∈f -` {s}. actions M x) = (⋃x∈f -` {s} ∩ states M. actions M x)"
using in_states[of M] by auto
with assms show ?thesis
by (auto simp add: actions_map_mdpc)
qed
lift_definition fix_loop :: "'s ⇒ 's mdpc ⇒ 's mdpc"
is "λs M t. if s = t then Some {return_pmf s} else M t" .
lemma states_fix_loop[simp]: "states (fix_loop s M) = insert s (states M)"
by transfer (auto simp: subset_eq image_iff dom_def split: if_splits)
lemma actions_fix_loop[simp]: "actions (fix_loop s M) t = (if s = t then {return_pmf s} else actions M t)"
by transfer auto
lemma fix_loop_idem: "fix_loop s (fix_loop s M) = fix_loop s M"
by (auto intro!: mdpc_eqI)
lemma fix_loop_commute: "fix_loop s (fix_loop t M) = fix_loop t (fix_loop s M)"
by (auto intro!: mdpc_eqI)
lemma map_fix_loop:
assumes f_s: "⋀t. f s = f t ⟹ t = s"
shows "map_mdpc f (fix_loop s M) = fix_loop (f s) (map_mdpc f M)"
by (auto simp: states_map_mdpc actions_map_mdpc_eq_Collect split: if_splits intro!: mdpc_eqI dest!: f_s f_s[OF sym]) force+
lift_definition map_actions :: "('s ⇒ 's pmf set ⇒ 's pmf set) ⇒ 's mdpc ⇒ 's mdpc"
is "λm f s. map_option (m s) (f s)" .
lemma state_map_actions[simp]: "states (map_actions f φ) = states φ"
by transfer auto
lemma actions_map_actions[simp]: "(s ∉ states φ ⟹ f s {} = {}) ⟹ actions (map_actions f φ) s = f s (actions φ s)"
by transfer (auto split: option.splits)
lift_definition restrict_states :: "'s set ⇒ 's mdpc ⇒ 's mdpc"
is "λS f s. if s ∈ S then f s else None" .
lemma state_restrict_states[simp]: "states (restrict_states S φ) = states φ ∩ S"
by transfer (auto split: if_splits)
lemma actions_restrict_states[simp]: "actions (restrict_states S φ) s = (if s ∈ S then actions φ s else {})"
by transfer (auto split: if_splits)
lemma restrict_states_idem: "states φ ⊆ A ⟹ restrict_states A φ = φ"
by transfer (force simp: fun_eq_iff subset_eq dom_def)
instantiation mdpc :: (type) lattice
begin
lift_definition less_eq_mdpc :: "'s mdpc ⇒ 's mdpc ⇒ bool"
is "fun_ord (ord_option (⊆))" .
definition less_mdpc :: "'s mdpc ⇒ 's mdpc ⇒ bool"
where "less_mdpc f g ⟷ (f ≤ g ∧ ¬ g ≤ f)"
lift_definition inf_mdpc :: "'s mdpc ⇒ 's mdpc ⇒ 's mdpc"
is "λf g s. lift_option (∩) (f s) (g s)" .
lift_definition sup_mdpc :: "'s mdpc ⇒ 's mdpc ⇒ 's mdpc"
is "λf g s. combine_options (∪) (f s) (g s)" .
instance
proof
fix x y z :: "'s mdpc"
show "(x < y) = (x ≤ y ∧ ¬ y ≤ x)"
by (rule less_mdpc_def)
note ord =
fun_ord_refl[where 'b="'s", OF reflp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
fun_ord_trans[where 'b="'s", OF transp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
fun_ord_antisym[where 'b="'s", OF antisymp_ord_option[where 'a="'s pmf set"], of "(⊆)"]
show "x ≤ x" "x ≤ y ⟹ y ≤ z ⟹ x ≤ z" "x ≤ y ⟹ y ≤ x ⟹ x = y"
by (transfer; insert ord; auto simp: transp_def antisymp_def reflp_def)+
show "x ⊓ y ≤ x" "x ⊓ y ≤ y"
by (transfer; auto simp: fun_ord_def ord_option.simps lift_option_def split: Option.bind_split)+
show "x ≤ y ⟹ x ≤ z ⟹ x ≤ y ⊓ z"
apply transfer
subgoal premises prems for a b c
using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
done
show "x ≤ x ⊔ y" "y ≤ x ⊔ y"
by (transfer; auto simp: fun_ord_def ord_option.simps combine_options_def not_all_eq split: option.splits)+
show "y ≤ x ⟹ z ≤ x ⟹ y ⊔ z ≤ x"
apply transfer
subgoal premises prems for a b c
using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
done
qed
end
instantiation mdpc :: (type) complete_lattice
begin
lift_definition bot_mdpc :: "'a mdpc" is "λ_. None" .
lift_definition top_mdpc :: "'a mdpc" is "λ_. Some UNIV" .
lift_definition Sup_mdpc :: "'a mdpc set ⇒ 'a mdpc"
is "λM s. if ∃m∈M. m s ≠ None then Some (⋃{ d | m d. m ∈ M ∧ m s = Some d}) else None" .
lift_definition Inf_mdpc :: "'a mdpc set ⇒ 'a mdpc"
is "λM s. if ∃m∈M. m s = None then None else Some (⋂{ d | m d. m ∈ M ∧ m s = Some d})" .
instance
proof
fix x :: "'a mdpc" and X :: "'a mdpc set"
show "x ∈ X ⟹ ⨅X ≤ x" "x ∈ X ⟹ x ≤ ⨆X"
by (transfer; force simp: fun_ord_def ord_option_Some1_iff ord_option_Some2_iff)+
show "(⋀y. y ∈ X ⟹ x ≤ y) ⟹ x ≤ ⨅X"
apply transfer
apply (clarsimp simp: fun_ord_def ord_option.simps)
subgoal premises P for X m x
using P[rule_format, of _ x]
by (cases "m x") fastforce+
done
show "(⋀y. y ∈ X ⟹ y ≤ x) ⟹ ⨆X ≤ x"
apply transfer
apply (clarsimp simp: fun_ord_def ord_option.simps)
subgoal premises P for X m x y z
using P(1)[rule_format, of _ x] P(1)[rule_format, of y x] P(2,3)
by auto force
done
qed (transfer; auto)+
end
lemma states_sup[simp]: "states (φ ⊔ ψ) = states φ ∪ states ψ"
by transfer (auto simp: combine_options_def split: option.splits)
lemma states_SUP[simp]: "states (⨆A) = (⋃a∈A. states a)"
by transfer (auto simp: dom_def split: option.splits if_splits)
lemma states_inf[simp]: "states (φ ⊓ ψ) = states φ ∩ states ψ"
by transfer (auto simp: lift_option_eq_Some split: option.splits)
lemma states_mono: "φ ≤ ψ ⟹ states φ ⊆ states ψ"
using states_sup[of φ ψ] by (auto simp del: states_sup simp add: sup_absorb2)
lemma actions_sup[simp]: "actions (φ ⊔ ψ) = actions φ ⊔ actions ψ"
by transfer (auto simp: combine_options_def split: option.splits)
lemma actions_SUP[simp]: "actions (⨆A) s = (⋃a∈A. actions a s)"
by transfer (auto simp: dom_def split: option.splits if_splits, blast)
lemma actions_inf[simp]: "actions (φ ⊓ ψ) = actions φ ⊓ actions ψ"
by transfer (auto simp: fun_eq_iff split: option.splits)
lemma actions_mono: assumes *: "φ ≤ ψ" shows "actions φ ≤ actions ψ"
proof -
have "actions φ ≤ actions φ ⊔ actions ψ"
by auto
also have "… = actions ψ"
using * actions_sup[of φ ψ] by (auto simp add: sup_absorb2)
finally show ?thesis .
qed
lemma le_mdpcI: "states M ⊆ states N ⟹ (⋀s. s ∈ states M ⟹ actions M s ⊆ actions N s) ⟹ M ≤ N"
by transfer
(force simp: fun_ord_def ord_option.simps subset_eq split: option.splits)
lemma le_mdpc_iff: "M ≤ N ⟷ states M ⊆ states N ∧ (∀s. actions M s ⊆ actions N s)"
using states_mono[of M N] actions_mono[of M N] by (auto simp: le_fun_def intro!: le_mdpcI)
lemma map_actions_le: "(⋀s A. s ∈ states φ ⟹ f s A ⊆ A) ⟹ map_actions f φ ≤ φ"
apply (intro le_mdpcI)
subgoal by auto
subgoal premises p for s using p(1)[of s] p(1)[of s "{}"] p(2) actions_map_actions by auto
done
lemma restrict_states_mono: "A ⊆ B ⟹ φ ≤ ψ ⟹ restrict_states A φ ≤ restrict_states B ψ"
using states_mono[of φ ψ] actions_mono[of φ ψ] by (intro le_mdpcI) (auto simp: le_fun_def)
lemma restrict_states_le: "restrict_states A M ≤ M"
by (intro le_mdpcI) auto
lemma eq_bot_iff_states: "φ = bot ⟷ states φ = {}"
by transfer auto
lemma fix_loop_neq_bot: "fix_loop s N ≠ bot"
unfolding eq_bot_iff_states by simp
lemma
shows states_bot[simp]: "states bot = {}"
and actions_bot[simp]: "actions bot = (λs. {})"
unfolding fun_eq_iff by (transfer; auto)+
lemma inf_eq_bot_eq_disjnt_states: "A ⊓ B = bot ⟷ disjnt (states A) (states B)"
unfolding disjnt_def by transfer (auto simp: fun_eq_iff lift_option_eq_None)
text ‹Enabled States›
definition en :: "'s mdpc ⇒ 's rel"
where "en φ = {(s, t) | d s t. d ∈ actions φ s ∧ t ∈ set_pmf d}"
lemma en_sup[simp]: "en (φ ⊔ ψ) = en φ ∪ en ψ"
by (auto simp: en_def)
lemma en_SUP[simp]: "en (Sup A) = (⋃a∈A. en a)"
by (auto simp: en_def)
lemma en_mono: "φ ≤ ψ ⟹ en φ ⊆ en ψ"
unfolding en_def
apply transfer
apply (auto simp: fun_ord_def split: option.splits)
apply (auto simp add: ord_option.simps subset_iff)
apply force
done
lemma en_states: "(s, t) ∈ en M ⟹ s ∈ states M"
using in_states[of M s] by (auto simp: en_def)
lemma en_bot[simp]: "en bot = {}"
by (simp add: en_def)
lemma en_fix_loop[simp]: "en (fix_loop s M) = insert (s, s) (en M - {s} × UNIV)"
by (force simp add: en_def )
lift_definition trivial :: "'s ⇒ 's mdpc" is "λs. (λ_. None)(s := Some {})" .
lemma states_trivial[simp]: "states (trivial s) = {s}"
by transfer auto
lemma actions_trivial[simp]: "actions (trivial s) = (λ_. {})"
by transfer (auto simp: fun_eq_iff)
lemma en_trivial[simp]: "en (trivial s) = {}"
by (simp add: en_def)
lemma trivial_le_iff: "trivial x ≤ φ ⟷ x ∈ states φ"
by transfer (auto simp: ord_option.simps fun_ord_def)
lemma trivial_le: "x ∈ states φ ⟹ trivial x ≤ φ"
unfolding trivial_le_iff .
lemma trivial_neq_bot: "trivial x ≠ bot"
by transfer auto
lift_definition loop :: "'s ⇒ 's mdpc"
is "λs. (λ_. None)(s := Some {return_pmf s})" .
lemma states_loop[simp]: "states (loop s) = {s}"
by transfer auto
lemma actions_loop: "actions (loop s) = ((λ_. {})(s := {return_pmf s}))"
by transfer (auto simp: fun_eq_iff)
lemma
shows actions_loop_self[simp]: "actions (loop s) s = {return_pmf s}"
and actions_loop_neq[simp]: "s ≠ t ⟹ actions (loop s) t = {}"
by (simp_all add: actions_loop)
lemma en_loop[simp]: "en (loop s) = {(s, s)}"
by (auto simp: en_def actions_loop)
lemma loop_neq_bot: "loop s ≠ bot"
unfolding eq_bot_iff_states by simp
lemma loop_le: "loop x ≤ M ⟷ (x ∈ states M ∧ return_pmf x ∈ actions M x)"
by (auto simp: le_mdpc_iff actions_loop)
lemma le_loop: "M ≤ loop x ⟷ (states M ⊆ {x} ∧ actions M x ⊆ {return_pmf x})"
using in_states[of M] by (auto simp: le_mdpc_iff actions_loop)
text ‹Strongly Connected (SC)›
definition sc :: "'s mdpc ⇒ bool"
where "sc φ ⟷ states φ × states φ ⊆ (en φ)⇧*"
lemma scD: "sc φ ⟹ x ∈ states φ ⟹ y ∈ states φ ⟹ (x, y) ∈ (en φ)⇧*"
by (auto simp: sc_def)
lemma scI: "(⋀x y. x ∈ states φ ⟹ y ∈ states φ ⟹ (x, y) ∈ (en φ)⇧*) ⟹ sc φ"
by (auto simp: sc_def)
lemma sc_trivial[simp]: "sc (trivial s)"
by (simp add: sc_def)
lemma sc_loop[simp]: "sc (loop s)"
by (auto simp: sc_def)
lemma sc_bot[simp]: "sc bot"
by (simp add: sc_def)
lemma sc_SupI_directed:
assumes A: "⋀a. a ∈ A ⟹ sc a"
and directed: "⋀a b. a ∈ A ⟹ b ∈ A ⟹ ∃c∈A. a ≤ c ∧ b ≤ c"
shows "sc (Sup A)"
unfolding sc_def
proof clarsimp
fix x y a b assume "a ∈ A" "b ∈ A" and xy: "x ∈ states a" "y ∈ states b"
with directed obtain c where "c ∈ A" "a ≤ c" "b ≤ c"
by auto
with xy have "x ∈ states c" "y ∈ states c"
using states_mono[of a c] states_mono[of b c] by auto
with A[OF ‹c ∈ A›] ‹c ∈ A›
have "(x, y) ∈ (en c)⇧*"
by (auto simp: sc_def subset_eq)
then show "(x, y) ∈ (⋃x∈A. en x)⇧*"
using rtrancl_mono[of "en c" "⋃a∈A. en a"] ‹c∈A› by auto
qed
lemma sc_supI:
assumes φ: "sc φ" and ψ: "sc ψ" and not_disjoint: "φ ⊓ ψ ≠ bot"
shows "sc (φ ⊔ ψ)"
unfolding sc_def
proof safe
fix x y assume "x ∈ states (φ ⊔ ψ)" "y ∈ states (φ ⊔ ψ)"
moreover obtain z where "z ∈ states φ" "z ∈ states ψ"
using not_disjoint by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)
moreover have "(en φ)⇧* ∪ (en ψ)⇧* ⊆ (en (φ ⊔ ψ))⇧*"
by (metis rtrancl_Un_subset en_sup)
ultimately have "(x, z) ∈ (en (φ ⊔ ψ))⇧*" "(z, y) ∈ (en (φ ⊔ ψ))⇧*"
using φ ψ by (auto dest: scD)
then show "(x, y) ∈ (en (φ ⊔ ψ))⇧*"
by auto
qed
lemma sc_eq_loop:
assumes M: "sc M" and s: "s ∈ M" "actions M s = {return_pmf s}" shows "M = loop s"
proof -
{ fix t assume "t ∈ M"
then have "(s, t) ∈ (en M)⇧*"
using M[THEN scD, OF ‹s ∈ M› ‹t ∈ M›] by simp
from this have "t = s"
by (induction rule: rtrancl_induct) (auto simp: en_def ‹actions M s = {return_pmf s}›) }
then have "states M = {s}"
using ‹s ∈ M› by blast
then show ?thesis
by (intro mdpc_eqI) (auto simp: ‹actions M s = {return_pmf s}›)
qed
lemma sc_eq_trivial:
assumes M: "sc M" and s: "s ∈ M" "actions M s = {}" shows "M = trivial s"
proof -
{ fix t assume "t ∈ M" "t ≠ s"
then have "(s, t) ∈ (en M)⇧+"
using M[THEN scD, OF ‹s ∈ M› ‹t ∈ M›] by (simp add: rtrancl_eq_or_trancl)
from tranclD[OF this] ‹actions M s = {}› have False
by (auto simp: en_def) }
then have "states M = {s}"
using ‹s ∈ M› by auto
then show ?thesis
by (intro mdpc_eqI) (auto simp: ‹actions M s = {}›)
qed
definition closed_mdpc :: "'s mdpc ⇒ bool"
where "closed_mdpc φ ⟷ en φ ⊆ states φ × states φ"
lemma closed_mdpcD: "closed_mdpc φ ⟹ D ∈ actions φ x ⟹ y ∈ D ⟹ y ∈ states φ"
by (auto simp: closed_mdpc_def en_def)
lemma closed_mdpc_supI: "closed_mdpc φ ⟹ closed_mdpc ψ ⟹ closed_mdpc (φ ⊔ ψ)"
by (auto simp: closed_mdpc_def)
lemma closed_mdpc_SupI: "(⋀a. a ∈ A ⟹ closed_mdpc a) ⟹ closed_mdpc (⨆A)"
by (auto simp: closed_mdpc_def)
lemma closed_mdpc_infI: "closed_mdpc φ ⟹ closed_mdpc ψ ⟹ closed_mdpc (φ ⊓ ψ)"
using en_mono[of "φ ⊓ ψ" φ] en_mono[of "φ ⊓ ψ" ψ]
by (auto simp: closed_mdpc_def lift_option_eq_Some)
lemma closed_mdpc_trivial[simp]: "closed_mdpc (trivial s)"
by (simp add: closed_mdpc_def)
lemma closed_mdpc_bot[simp]: "closed_mdpc bot"
by (simp add: closed_mdpc_def)
lemma closed_mdpc_loop[simp]: "closed_mdpc (loop s)"
by (auto simp: closed_mdpc_def)
lemma closed_mdpc_fix_loop: "closed_mdpc M ⟹ closed_mdpc (fix_loop s M)"
by (auto simp: closed_mdpc_def)
lemma closed_mdpc_map: assumes M: "closed_mdpc M" shows "closed_mdpc (map_mdpc f M)"
using closed_mdpcD[OF M]
by (auto simp: closed_mdpc_def en_def actions_map_mdpc states_map_mdpc intro!: imageI intro: in_states)
definition close :: "'s mdpc ⇒ 's mdpc"
where "close φ = map_actions (λs A. {a∈A. set_pmf a ⊆ states φ}) φ"
lemma
shows states_close[simp]: "states (close φ) = states φ"
and actions_close[simp]: "actions (close φ) s = {a∈actions φ s. a ⊆ states φ}"
by (auto simp: close_def)
lemma closed_close: "closed_mdpc (close φ)"
by (auto simp add: closed_mdpc_def en_def intro: in_states)
lemma close_closed: "closed_mdpc φ ⟹ close φ = φ"
unfolding closed_mdpc_def by (intro mdpc_eqI) (auto simp: en_def)
lemma close_close: "close (close φ) = close φ"
by (simp add: closed_close close_closed)
lemma close_le: "close M ≤ M"
unfolding close_def by (intro map_actions_le) auto
lemma close_mono: "φ ≤ ψ ⟹ close φ ≤ close ψ"
using states_mono[of φ ψ] actions_mono[of φ ψ]
unfolding close_def by (intro le_mdpcI) (auto simp: le_fun_def)
text ‹End Component (EC)›
definition ec :: "'s mdpc ⇒ bool"
where "ec φ ⟷ sc φ ∧ closed_mdpc φ"
lemma ec_trivial[simp]: "ec (trivial s)"
by (auto simp: ec_def)
lemma ec_bot[simp]: "ec bot"
by (auto simp: ec_def)
lemma ec_loop[simp]: "ec (loop s)"
by (auto simp: ec_def)
lemma ec_sup: "ec φ ⟹ ec ψ ⟹ φ ⊓ ψ ≠ bot ⟹ ec (φ ⊔ ψ)"
by (simp add: ec_def sc_supI closed_mdpc_supI)
lemma ec_Sup_directed:
"(⋀a. a ∈ A ⟹ ec a) ⟹ (⋀a b. a ∈ A ⟹ b ∈ A ⟹ ∃c∈A. a ≤ c ∧ b ≤ c) ⟹ ec (⨆A)"
by (auto simp: ec_def closed_mdpc_SupI sc_SupI_directed)
text ‹Maximal End Component (MEC) relative to @{term M}›
definition mec :: "'s mdpc ⇒ 's mdpc ⇒ bool"
where "mec M φ ⟷ ec φ ∧ φ ≤ M ∧ (∀ψ≤M. ec ψ ⟶ φ ≤ ψ ⟶ φ = ψ)"
lemma mec_refl: "ec M ⟹ mec M M"
by (auto simp: mec_def)
lemma mec_le: "mec M φ ⟹ φ ≤ M"
by (auto simp: mec_def)
lemma mec_ec: "mec M φ ⟹ ec φ"
by (auto simp: mec_def)
lemma mec_least: "mec M φ ⟹ ψ ≤ M ⟹ φ ≤ ψ ⟹ ec ψ ⟹ φ ≥ ψ"
by (auto simp: mec_def)
lemma mec_bot_imp_bot: assumes "mec φ bot" shows "φ = bot"
proof (rule ccontr)
assume "φ ≠ bot"
then obtain x where "x ∈ states φ"
unfolding eq_bot_iff_states by auto
then have "ec (trivial x)" "trivial x ≤ φ"
by (auto intro: trivial_le)
then have "trivial x = bot"
using ‹mec φ bot› by (auto simp: mec_def)
then show False
by (simp add: trivial_neq_bot)
qed
lemma mec_imp_bot_eq_bot: "mec φ ψ ⟹ φ = bot ⟷ ψ = bot"
using mec_bot_imp_bot[of φ] by (auto simp: mec_def)
lemma mec_unique: assumes φ: "mec M φ" and ψ: "mec M ψ" and "φ ⊓ ψ ≠ bot" shows "φ = ψ"
proof -
have "mec M (φ ⊔ ψ)"
using assms
by (auto intro!: mec_def[THEN iffD2] ec_sup antisym dest: mec_ec mec_le)
(blast intro: le_supI1 mec_least[of M])
with mec_least[OF φ, of "φ ⊔ ψ"] mec_least[OF ψ, of "φ ⊔ ψ"] mec_le[OF this] mec_ec[OF this]
show "φ = ψ"
by auto
qed
lemma mec_exists: assumes φ: "φ ≠ bot" "ec φ" and M: "φ ≤ M" shows "∃ψ≥φ. mec M ψ"
proof (intro exI conjI)
show "φ ≤ ⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ}"
using φ M by (intro Sup_upper) auto
show "mec M (⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ})"
unfolding mec_def
proof safe
show "ec (⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ})"
proof (safe intro!: ec_Sup_directed)
fix a b assume *: "φ ≤ a" "φ ≤ b" and "a ≤ M" "b ≤ M" "ec a" "ec b"
moreover have "a ⊓ b ≠ bot"
using * φ bot_unique[of "φ"] le_inf_iff[of φ a b] by (auto simp del: inf.bounded_iff)
ultimately show "∃c∈{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ}. a ≤ c ∧ b ≤ c"
by (intro bexI[of _ "sup a b"]) (auto intro: le_supI1 intro!: ec_sup)
qed
fix ψ assume ψ: "ψ ≤ M" "ec ψ" "⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ} ≤ ψ"
have "φ ≤ ⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ}"
using assms by (auto intro!: Sup_upper)
also have "… ≤ ψ" by fact
finally show "⨆{ψ. φ ≤ ψ ∧ ψ ≤ M ∧ ec ψ} = ψ"
using ψ by (intro antisym Sup_upper) auto
qed (auto intro!: Sup_least)
qed
lemma mec_exists': "x ∈ states M ⟹ ∃ψ. x ∈ states ψ ∧ mec M ψ"
using mec_exists[of "trivial x"] by (auto simp: trivial_neq_bot trivial_le_iff)
lemma mec_loop: "x ∈ states M ⟹ actions M x = {return_pmf x} ⟹ mec M (loop x)"
apply (auto simp: mec_def loop_le ec_def)
subgoal for φ
using sc_eq_loop[of φ x] actions_mono[of φ M, THEN le_funD, of x] by auto
done
lemma mec_fix_loop: "mec (fix_loop s M) (loop s)"
by (intro mec_loop) auto
definition trivials :: "'s mdpc ⇒ 's set"
where "trivials M = {x. mec M (trivial x)}"
lemma trivials_subset_states: "trivials M ⊆ states M"
by (auto simp: trivials_def mec_def trivial_le_iff)
text ‹Bottom MEC (BEMC) in @{term M}›
definition bmec :: "'s mdpc ⇒ 's mdpc ⇒ bool"
where "bmec M φ ⟷ mec φ M ∧ (∀s∈states φ. actions φ s = actions M s)"
definition actions' :: "'s mdpc ⇒ 's ⇒ 's pmf set"
where "actions' M s = (if s ∈ states M then actions M s else {return_pmf s})"
lemma closed_mdpcD':
"closed_mdpc M ⟹ s ∈ states M ⟹ (⋃D∈actions' M s. set_pmf D) ⊆ states M"
by (auto simp: actions'_def dest: closed_mdpcD)
locale Finite_MDP =
fixes M :: "'s mdpc"
assumes closed_M: "closed_mdpc M" and M_neq_bot: "M ≠ bot"
and actions_neq_empty_M: "⋀s. s ∈ states M ⟹ actions M s ≠ {}"
and finite_states_M: "finite M"
and finite_actions_M: "⋀s. finite (actions M s)"
begin
sublocale Finite_Markov_Decision_Process "actions' M" "states M"
proof
show "actions' M s ≠ {}" for s
using actions_neq_empty_M by (auto simp: actions'_def )
show "states M ≠ {}" "finite M" "⋀s. finite (actions' M s)"
using M_neq_bot finite_states_M finite_actions_M by (auto simp: eq_bot_iff_states actions'_def)
show "s ∈ states M ⟹ (⋃D∈actions' M s. set_pmf D) ⊆ states M" for s
using closed_M by (rule closed_mdpcD')
qed
lemma Finite_MDP_map_loop: "Finite_MDP (map_mdpc f M ⊔ loop s)"
proof
show "closed_mdpc (map_mdpc f M ⊔ loop s)"
by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_loop)
show "finite (actions (map_mdpc f M ⊔ loop s) t)" for t
by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
show "finite (map_mdpc f M ⊔ loop s)"
by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: loop_neq_bot states_map_mdpc actions_loop actions_map_mdpc dest: actions_neq_empty_M)
lemma Finite_MDP_map_fix_loop: "Finite_MDP (fix_loop s (map_mdpc f M))"
proof
show "closed_mdpc (fix_loop s (map_mdpc f M))"
by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_fix_loop)
show "finite (actions (fix_loop s (map_mdpc f M)) t)" for t
by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
show "finite (fix_loop s (map_mdpc f M))"
by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: fix_loop_neq_bot states_map_mdpc actions_map_mdpc dest: actions_neq_empty_M)
end
context
fixes M :: "'s mdpc"
and F :: "'s set"
assumes M_neq_bot: "M ≠ bot"
and closed_M: "closed_mdpc M"
and actions_neq_empty_M: "⋀s. s ∈ states M ⟹ actions M s ≠ {}"
and finite_states_M: "finite M"
and finite_actions_M: "⋀s. finite (actions M s)"
and F_subset: "F ⊆ states M"
begin
lemma finite_F[simp]: "finite F"
using F_subset finite_states_M by (auto dest: finite_subset)
interpretation M: Finite_MDP M
proof qed fact+
interpretation M: Reachability_Problem "actions' M" "states M" "states M - F" F
proof qed (insert F_subset, auto)
definition r :: "'s ⇒ 's option"
where "r s = (if s ∈ F then None else Some s)"
lemma r_eq_None[simp]: "r s = None ⟷ s ∈ F"
by (simp add: r_def)
lemma r_eq_Some[simp]: "r s = Some t ⟷ (s ∉ F ∧ s = t)"
by (simp add: r_def)
lemma r_in_Some_image: "r s ∈ Some ` X ⟷ (s ∉ F ∧ s ∈ X)"
by (auto simp: r_def)
lemma r_inj: "s ∉ F ∨ t ∉ F ⟹ r s = r t ⟷ s = t"
by (auto simp: r_def)
lemma shows r_F: "s ∈ F ⟹ r s = None" and r_nF: "s ∉ F ⟹ r s = Some s"
by auto
definition R :: "'s option mdpc"
where "R = fix_loop None (map_mdpc r M)"
lemma closed_R: "closed_mdpc R"
unfolding R_def by (intro closed_mdpc_map closed_M closed_mdpc_fix_loop)
lemma states_R[simp]: "states R = Some ` (states M - F) ∪ {None}"
by (auto simp add: R_def r_def[abs_def] states_map_mdpc)
lemma actions_R_None[simp]:
"actions R None = {return_pmf None}"
by (auto simp add: R_def)
lemma actions_R_Some[simp]:
"actions R (Some s) = (if s ∈ F then {} else map_pmf r ` actions M s)"
by (auto simp add: R_def actions_map_mdpc split: if_splits intro!: imageI)
lemma mec_R_loop: "mec R (loop None)"
unfolding R_def by (intro mec_fix_loop)
interpretation R: Finite_MDP R
unfolding R_def by (rule M.Finite_MDP_map_fix_loop)
interpretation R: Reachability_Problem "actions' R" "states R" "{None}" "{}"
proof qed auto
lemma F_not_trivial: "s ∈ F ⟹ Some s ∉ trivials R"
by (auto simp: trivials_def mec_def trivial_le_iff)
primrec min_state :: "'s option ⇒ 's + bool"
where
"min_state None = Inr True"
| "min_state (Some s) = (if Some s ∈ trivials R then Inl s else Inr False)"
lemma min_state_eq_Inl: "min_state s = Inl t ⟷ (Some t ∈ trivials R ∧ s = Some t)"
by (cases s) auto
lemma min_state_eq_Inr: "min_state s = Inr b ⟷ (if b then s = None else s ≠ None ∧ s ∉ trivials R)"
by (cases s) auto
lemma map_min_state_R: "map_mdpc min_state R = fix_loop (Inr True) (map_mdpc (min_state ∘ r) M)"
unfolding R_def
by (subst map_fix_loop)
(auto simp: map_mdpc_compose min_state_eq_Inr eq_commute[of "Inr True"])
definition min_mdpc :: "('s + bool) mdpc"
where "min_mdpc = fix_loop (Inr False) (map_mdpc min_state R)"
lemma states_min_mdpc: "states min_mdpc = {Inl t | t. Some t ∈ trivials R} ∪ {Inr True, Inr False}"
using trivials_subset_states[of R] by (auto simp add: min_mdpc_def states_map_mdpc image_comp split: if_splits)
lemma actions_min_mdpc_Inl:
"actions min_mdpc (Inl t) = (if Some t ∈ trivials R then map_pmf (min_state ∘ r) ` actions M t else {})"
proof -
have eq: "min_state -` {Inl t} = (if Some t ∈ trivials R then {Some t} else {})"
by (auto simp: min_state_eq_Inl)
show ?thesis using F_not_trivial[of t]
by (simp add: min_mdpc_def actions_map_mdpc eq image_comp map_pmf_compose[symmetric])
qed
lemma actions_min_mdpc_Inr: "actions min_mdpc (Inr b) = {return_pmf (Inr b)}"
by (simp add: min_mdpc_def map_min_state_R)
interpretation min: Finite_MDP min_mdpc
unfolding min_mdpc_def by (rule R.Finite_MDP_map_fix_loop)
interpretation min: Reachability_Problem "actions' min_mdpc" "states min_mdpc" "states min_mdpc - {Inr True}" "{Inr True}"
proof qed (auto simp: states_min_mdpc)
lemma M_n_eq_0_not_trivials:
assumes "s ∈ states M" "s ∉ F" "Some s ∉ trivials R"
shows "M.n s = 0"
proof -
have "Some s ∈ states R"
using assms by auto
obtain φ where "mec R φ" "s ∈ Some -` φ"
using mec_exists'[OF ‹Some s ∈ states R›] by auto
then have action_φ: "Some t ∈ φ ⟹ actions φ (Some t) ≠ {}" for t
using mec_ec[OF ‹mec R φ›] ‹Some s ∉ trivials R› sc_eq_trivial[of φ "Some t"]
by (auto simp: ec_def trivials_def)
have None_notin_states: "None ∉ states φ"
using mec_R_loop ‹mec R φ› ‹s ∈ Some -` φ› mec_unique[of R "loop None" φ]
by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)
from ‹s ∈ Some -` φ› show "M.n s = 0"
proof (rule M.n_eq_0_closed)
show "Some -` states φ ⊆ states M" "Some -` states φ ∩ F = {}"
using mec_le[OF ‹mec R φ›] by (auto simp: r_def le_mdpc_iff)
fix s assume "s ∈ Some -` φ"
then have s: "s ∈ states M" "s ∉ F" "actions φ (Some s) ≠ {}"
using mec_le[OF ‹mec R φ›] by (auto simp: le_mdpc_iff action_φ)
then obtain D where D: "D ∈ actions φ (Some s)"
by auto
then have "D ∈ actions R (Some s)"
using mec_le[OF ‹mec R φ›, THEN actions_mono] s by (auto simp add: le_fun_def simp del: actions_R_Some)
with s obtain D' where D_eq: "D = map_pmf r D'" and D': "D' ∈ actions M s"
by auto
have "set_pmf D ⊆ states φ"
using closed_mdpcD[OF _ D] mec_ec[OF ‹mec R φ›] by (auto simp: ec_def)
then have "set_pmf D = Some ` set_pmf D'"
using closed_mdpcD[of φ, OF _ ‹D ∈ actions φ (Some s)›] None_notin_states
mec_ec[OF ‹mec R φ›]
unfolding D_eq by (auto intro!: image_cong simp: r_def ec_def)
then show "∃x∈actions' M s. set_pmf x ⊆ Some -` states φ"
using ‹s ∈ states M› ‹set_pmf D ⊆ states φ› D'
by (intro bexI[of _ D']) (auto simp: actions'_def)
qed
qed
lemma min_state_r_in_min_mdpc[simp]: "s ∈ M ⟹ min_state (r s) ∈ min_mdpc"
by (auto simp add: states_min_mdpc min_state_eq_Inr min_state_eq_Inl r_def)
end
end